hxt 9.1.6 → 9.3.1.22
raw patch · 42 files changed
Files
- examples/arrows/AGentleIntroductionToHXT/SimpleExamples.hs +1/−1
- examples/arrows/absurls/AbsURIs.hs +1/−1
- examples/arrows/dtd2hxt/DTDtoHXT.hs +1/−1
- examples/arrows/hparser/HXmlParser.hs +1/−1
- examples/arrows/pickle/Makefile +9/−1
- hxt.cabal +95/−21
- src/Control/Arrow/ArrowList.hs +6/−4
- src/Control/Arrow/ArrowNF.hs +9/−9
- src/Control/Arrow/ArrowTree.hs +1/−1
- src/Data/Atom.hs +10/−9
- src/Data/Tree/NTree/TypeDefs.hs +44/−8
- src/Text/XML/HXT/Arrow/Binary.hs +6/−8
- src/Text/XML/HXT/Arrow/DocumentInput.hs +62/−67
- src/Text/XML/HXT/Arrow/DocumentOutput.hs +35/−44
- src/Text/XML/HXT/Arrow/Edit.hs +18/−16
- src/Text/XML/HXT/Arrow/ParserInterface.hs +10/−4
- src/Text/XML/HXT/Arrow/Pickle.hs +35/−15
- src/Text/XML/HXT/Arrow/Pickle/Xml.hs +1517/−950
- src/Text/XML/HXT/Arrow/ProcessDocument.hs +29/−38
- src/Text/XML/HXT/Arrow/ReadDocument.hs +156/−62
- src/Text/XML/HXT/Arrow/XmlArrow.hs +5/−5
- src/Text/XML/HXT/Arrow/XmlOptions.hs +1/−1
- src/Text/XML/HXT/Arrow/XmlRegex.hs +88/−29
- src/Text/XML/HXT/Arrow/XmlState.hs +2/−1
- src/Text/XML/HXT/Arrow/XmlState/RunIOStateArrow.hs +18/−0
- src/Text/XML/HXT/Arrow/XmlState/SystemConfig.hs +16/−3
- src/Text/XML/HXT/Arrow/XmlState/TypeDefs.hs +143/−98
- src/Text/XML/HXT/Arrow/XmlState/URIHandling.hs +2/−1
- src/Text/XML/HXT/DOM/QualifiedName.hs +37/−32
- src/Text/XML/HXT/DOM/ShowXml.hs +79/−68
- src/Text/XML/HXT/DOM/TypeDefs.hs +12/−11
- src/Text/XML/HXT/DTDValidation/DTDValidation.hs +4/−2
- src/Text/XML/HXT/DTDValidation/RE.hs +48/−27
- src/Text/XML/HXT/DTDValidation/Validation.hs +5/−5
- src/Text/XML/HXT/DTDValidation/XmlRE.hs +9/−9
- src/Text/XML/HXT/IO/GetFILE.hs +8/−8
- src/Text/XML/HXT/Parser/HtmlParsec.hs +7/−2
- src/Text/XML/HXT/Parser/XmlCharParser.hs +16/−19
- src/Text/XML/HXT/Parser/XmlParsec.hs +56/−65
- src/Text/XML/HXT/Parser/XmlTokenParser.hs +8/−4
- src/Text/XML/HXT/Version.hs +1/−1
- src/Text/XML/HXT/XMLSchema/DataTypeLibW3CNames.hs +30/−3
examples/arrows/AGentleIntroductionToHXT/SimpleExamples.hs view
@@ -31,7 +31,7 @@ (al, fct, src, dst) <- cmdlineOpts argv [rc] <- runX (application al fct src dst) if rc >= c_err- then exitWith (ExitFailure (-1))+ then exitWith (ExitFailure 1) else exitWith ExitSuccess application :: SysConfigList -> String -> String -> String -> IOSArrow b Int
examples/arrows/absurls/AbsURIs.hs view
@@ -45,7 +45,7 @@ -- ------------------------------------------------------------ exitProg :: Bool -> IO a-exitProg True = exitWith (ExitFailure (-1))+exitProg True = exitWith (ExitFailure 1) exitProg False = exitWith ExitSuccess -- ------------------------------------------------------------
examples/arrows/dtd2hxt/DTDtoHXT.hs view
@@ -37,7 +37,7 @@ -- ------------------------------------------------------------ exitProg :: Bool -> IO a-exitProg True = exitWith (ExitFailure (-1))+exitProg True = exitWith (ExitFailure 1) exitProg False = exitWith ExitSuccess -- ------------------------------------------------------------
examples/arrows/hparser/HXmlParser.hs view
@@ -51,7 +51,7 @@ -- ------------------------------------------------------------ exitProg :: Bool -> IO a-exitProg True = exitWith (ExitFailure (-1))+exitProg True = exitWith (ExitFailure 1) exitProg False = exitWith ExitSuccess -- ------------------------------------------------------------
examples/arrows/pickle/Makefile view
@@ -10,7 +10,7 @@ DIST = $(HXT_HOME)/dist/examples/arrows DIST_DIR = $(DIST)/pickle -PROG = ./pickleTest+PROG = ./pickleTest ./pickleTestWithNamespaces all : $(PROG) @@ -23,6 +23,11 @@ @echo "the program p2 as XML document" @sleep 3 cat pickle.xml+ ./pickleTestWithNamespaces+ @sleep 1+ @echo "the program p2 as XML document"+ @sleep 3+ cat pickle.xml dist : [ -d $(DIST_DIR) ] || mkdir -p $(DIST_DIR)@@ -37,4 +42,7 @@ .PHONY : all test dist clean distclean force pickleTest : PickleTest.hs+ $(GHC) --make -o $@ $<++pickleTestWithNamespaces : PickleTestWithNamespaces.hs $(GHC) --make -o $@ $<
hxt.cabal view
@@ -1,6 +1,6 @@ -- arch-tag: Haskell XML Toolbox main description file Name: hxt-Version: 9.1.6+Version: 9.3.1.22 Synopsis: A collection of tools for processing XML with Haskell. Description: The Haskell XML Toolbox bases on the ideas of HaXml and HXML, but introduces a more general approach for processing XML with Haskell.@@ -12,19 +12,68 @@ The library makes extensive use of the arrow approach for processing XML. 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-curl, hxt-tagsoup, hxt-relaxng, hxt-xpath, hxt-xslt,+ hxt-regex-xmlschema contain the extensions. hxt-unicode contains encoding and decoding functions, hxt-charproperties char properties for unicode and XML.+ Changes from 9.3.1.21: ghc-9.0 compatibility+ .+ Changes from 9.3.1.20: ghc 8.10 and 9.0 compatibility, tuple picker up to 24-tuples, Either instance for xpickle+ .+ Changes from 9.3.1.19: ghc-8.8.2 compatibility+ .+ Changes from 9.3.1.15: Bug in quoting PI instructions in showXmlTrees fixed+ .+ Changes from 9.3.1.14: For ghc-7.10 network-uri is automatically selected + .+ Changes from 9.3.1.13: ghc-7.10 compatibility+ .+ Changes from 9.3.1.12: Bug when unpickling an empty attribute value removed+ .+ Changes from 9.3.1.11: Bug fix in haddock comments+ .+ Changes from 9.3.1.10: Bug in DTD validation, space and time leak in delta removed+ .+ Changes from 9.3.1.9: lower bound of mtl dependency lowered to 2.0.1+ .+ Changes from 9.3.1.8: Bug in hread removed+ .+ Changes from 9.3.1.7: Foldable and Traversable instances for NTree added+ Control.Except used instead of deprecated Control.Error+ .+ Changes from 9.3.1.6: canonicalize added in hread and hreadDoc+ .+ Changes from 9.3.1.4: conditionally (no default)+ dependency from networt changed to network-uri with flag "network-uri"+ .+ Changes from 9.3.1.3: warnings from ghc-7.8.1 removed+ .+ Changes from 9.3.1.2: https as protocol added+ .+ Changes from 9.3.1.1: new parser xreadDoc+ .+ Changes from 9.3.1.0: in readString all input decoding switched off+ .+ Changes from 9.3.0.1: lower bound for network set to be >= 2.4+ .+ Changes from 9.3.0: upper bound for network set to be < 2.4+ (URI signatures changed in 2.4)+ .+ Changes from 9.2.2: XMLSchema validation integrated+ .+ Changes from 9.2.1: user defined mime type handlers added+ .+ Changes from 9.2.0: New warnings from ghc-7.4 removed License: MIT License-file: LICENSE Author: Uwe Schmidt, Martin Schmidt, Torben Kuseler Maintainer: Uwe Schmidt <uwe@fh-wedel.de> Stability: Stable Category: XML-Homepage: http://www.fh-wedel.de/~si/HXmlToolbox/index.html-Copyright: Copyright (c) 2005-2010 Uwe Schmidt+Homepage: https://github.com/UweSchmidt/hxt+Copyright: Copyright (c) 2005-2019 Uwe Schmidt Build-type: Simple-Cabal-version: >=1.6+Cabal-version: >=1.10 extra-source-files: examples/arrows/absurls/AbsURIs.hs@@ -73,6 +122,16 @@ examples/xhtml/xhtml-symbol.ent examples/xhtml/xhtml.xml +flag network-uri+ description: Get Network.URI from the network-uri package,+ with ghc < 7.10 default is False,+ with ghc >= 7.10 default is True + default: False++flag profile+ description: turn profiling on+ default: False+ library exposed-modules: Control.Arrow.ArrowExc,@@ -158,23 +217,38 @@ Text.XML.HXT.XMLSchema.DataTypeLibW3CNames, Text.XML.HXT.Version + default-language: Haskell2010+ hs-source-dirs: src - ghc-options: -Wall- ghc-prof-options: -auto-all -caf-all+ ghc-options: -Wall -fwarn-tabs - extensions: MultiParamTypeClasses DeriveDataTypeable FunctionalDependencies FlexibleInstances+ if flag(profile)+ ghc-prof-options: -caf-all - build-depends: base >= 4 && < 5,- containers >= 0.2 && < 1,- directory >= 1 && < 2,- filepath >= 1 && < 2,- parsec >= 2.1 && < 4,- HUnit >= 1.2 && < 2,- network >= 2.1 && < 3,- deepseq >= 1.1 && < 2,- bytestring >= 0.9 && < 1,- binary >= 0.5 && < 1,- hxt-charproperties >= 9.1 && < 10,- hxt-unicode >= 9.0.1 && < 10,- hxt-regex-xmlschema >= 9 && < 10+ default-extensions: MultiParamTypeClasses DeriveDataTypeable FunctionalDependencies FlexibleInstances CPP++ build-depends: base >= 4 && < 5,+ containers >= 0.2,+ directory >= 1,+ filepath >= 1,+ parsec >= 2.1 && < 4,+ mtl >= 2.0.1 && < 3,+ deepseq >= 1.1,+ bytestring >= 0.9,+ binary >= 0.5,+ hxt-charproperties >= 9.1,+ hxt-unicode >= 9.0.1,+ hxt-regex-xmlschema >= 9.2++ if flag(network-uri)+ build-depends: network-uri >= 2.6+ else+ if impl(ghc >= 7.10)+ build-depends: network-uri >= 2.6+ else+ build-depends: network >= 2.4 && < 2.6++Source-Repository head+ Type: git+ Location: git://github.com/UweSchmidt/hxt.git
src/Control/Arrow/ArrowList.hs view
@@ -13,11 +13,13 @@ This module defines the interface for list arrows. - A list arrow is a function, that gives a list of results+ 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.+ An empty list often indicates that the function is undefined+ for the given argument.+ The empty list may also represent False, non-empty lists True.+ A list with more than one element gives all results for a+ so called nondeterministic function. -}
src/Control/Arrow/ArrowNF.hs view
@@ -18,11 +18,11 @@ module Control.Arrow.ArrowNF where -import Control.Arrow-import Control.Arrow.ArrowList+import Control.Arrow+import Control.Arrow.ArrowList -import Control.DeepSeq-import Control.FlatSeq+import Control.DeepSeq+import Control.FlatSeq -- | -- complete evaluation of an arrow result using 'Control.DeepSeq'@@ -35,14 +35,14 @@ strictA = arr $ \ x -> deepseq x x class (Arrow a) => ArrowNF a where- rnfA :: (NFData c) => a b c -> a b c- rnfA f = f >>^ (\ x -> deepseq x x)+ rnfA :: (NFData c) => a b c -> a b c+ rnfA f = f >>^ (\ x -> deepseq x x) {-# INLINE rnfA #-} -- | -- partial evaluation of an arrow result using 'Control.FlatSeq' ----- There are tow arrows with force the partial evaluation. By convention+-- There are two arrows with force the partial evaluation. By convention -- the 2. should be less lazy than the 1. -- -- These arrows are sometimes useful for preventing space leaks, especially when parsing@@ -54,8 +54,8 @@ rwnfA f = f >>. \ x -> rlnf rwnf x `seq` x {-# INLINE rwnfA #-} - rwnf2A :: (WNFData c) => a b c -> a b c- rwnf2A f = f >>. \ x -> rlnf rwnf2 x `seq` x+ rwnf2A :: (WNFData c) => a b c -> a b c+ rwnf2A f = f >>. \ x -> rlnf rwnf2 x `seq` x {-# INLINE rwnf2A #-} -- ------------------------------------------------------------
src/Control/Arrow/ArrowTree.hs view
@@ -147,7 +147,7 @@ -- -- This expression selects -- all top level \"table\" elements within an \"html\" element, an expression.- -- Attantion: This does not correspond+ -- Attention: This does not correspond -- to the XPath selection path \"html\/\/table\". The latter on matches all table elements -- even nested ones, but @\/\/>@ gives in many cases the appropriate functionality.
src/Data/Atom.hs view
@@ -14,7 +14,7 @@ Unique Atoms generated from Strings and managed as flyweights - Data.Atom can be used for caching and storage optimisation+ Data.Atom can be used for caching and storage optimization of frequently used strings. An @Atom@ is constructed from a @String@. For two equal strings the identical atom is returned. @@ -42,7 +42,7 @@ > s `compare` t => newAtom s `compare` newAtom t > show . newAtom == id - Equality test for @Atom@s runs in /O(1)/, it is just a pointer comarison.+ Equality test for @Atom@s runs in /O(1)/, it is just a pointer comparison. The @Ord@ comparisons have the same runtime like the @ByteString@ comparisons. Internally there is an UTF8 comparison, but UTF8 encoding preserves the total order. @@ -61,15 +61,15 @@ import Control.DeepSeq -import Data.ByteString.Internal ( toForeignPtr, c2w, w2c )-import Data.ByteString ( ByteString, pack, unpack )+import Data.ByteString (ByteString, pack, unpack)+import Data.ByteString.Internal (c2w, toForeignPtr, w2c) import Data.IORef-import qualified Data.Map as M-import Data.String.UTF8Decoding ( decodeUtf8 )-import Data.String.Unicode ( unicodeToUtf8 )+import qualified Data.Map as M+import Data.String.Unicode (unicodeToUtf8)+import Data.String.UTF8Decoding (decodeUtf8) import Data.Typeable -import System.IO.Unsafe ( unsafePerformIO )+import System.IO.Unsafe (unsafePerformIO) -- ------------------------------------------------------------ @@ -108,7 +108,7 @@ -- putStrLn "atom cache updated" return res where- insert m = let r = insertAtom (pack. map c2w . unicodeToUtf8 $ s) m + insert m = let r = insertAtom (pack. map c2w . unicodeToUtf8 $ s) m in fst r `seq` r @@ -138,5 +138,6 @@ -- show = show . toForeignPtr . bs -- for debug only instance NFData Atom where+ rnf x = seq x () -----------------------------------------------------------------------------
src/Data/Tree/NTree/TypeDefs.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -- ------------------------------------------------------------@@ -22,13 +23,31 @@ module Data.Tree.NTree.TypeDefs where -import Control.DeepSeq-import Control.FlatSeq+import Control.DeepSeq (NFData (..))+import Control.FlatSeq (WNFData (..), rlnf) -import Data.Binary-import Data.Tree.Class-import Data.Typeable+import Data.Binary+import Data.Tree.Class (Tree (..))+import Data.Typeable (Typeable) +#if MIN_VERSION_base(4,13,0)+#else+import Data.Monoid ((<>))+#endif++#if MIN_VERSION_base(4,8,2)+#else+import Control.Applicative ((<$>))+#endif++#if MIN_VERSION_base(4,8,0)+#else+import Control.Applicative (Applicative (..))+import Data.Foldable (Foldable (..))+import Data.Monoid (Monoid (..))+import Data.Traversable (Traversable (..), sequenceA)+#endif+ -- ------------------------------------------------------------ -- | n-ary ordered tree (rose trees)@@ -54,11 +73,11 @@ {-# INLINE rnf #-} instance (WNFData a) => WNFData (NTree a) where- rwnf (NTree n cl) = rwnf n `seq` rwnf cl+ rwnf (NTree n cl) = rwnf n `seq` rwnf cl {-# INLINE rwnf #-} -- | Evaluate a tree 2 steps deep, the top node and all children are evaluated with rwnf- rwnf2 (NTree n cl) = rwnf n `seq` rlnf rwnf cl+ rwnf2 (NTree n cl) = rwnf n `seq` rlnf rwnf cl {-# INLINE rwnf2 #-} -- ------------------------------------------------------------@@ -75,8 +94,25 @@ -- | NTree implements class Functor instance Functor NTree where- fmap f ~(NTree n cl) = NTree (f n) (map (fmap f) cl)+ fmap f (NTree n cl) = NTree (f n) (map (fmap f) cl) {-# INLINE fmap #-}++-- ------------------------------------------------------------++-- | NTree implements class Foldable++instance Foldable NTree where+ foldMap f (NTree n cl) = f n <> mconcat (map (foldMap f) cl)+ {-# INLINE foldMap #-}+++-- ------------------------------------------------------------++-- | NTree implements class Taversable++instance Traversable NTree where+ traverse f (NTree n cl) = NTree <$> f n <*> sequenceA (map (traverse f) cl)+ {-# INLINE traverse #-} -- ------------------------------------------------------------
src/Text/XML/HXT/Arrow/Binary.hs view
@@ -20,18 +20,16 @@ ) where -import Control.Arrow ()+import Control.Arrow () import Control.Arrow.ArrowExc-import Control.Arrow.ArrowList import Control.Arrow.ArrowIO+import Control.Arrow.ArrowList import Data.Binary-import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Lazy as B -import System.IO ( openBinaryFile- , hClose- , IOMode(..)- )+import System.IO (IOMode (..), hClose,+ openBinaryFile) import Text.XML.HXT.Arrow.XmlState.ErrorHandling import Text.XML.HXT.Arrow.XmlState.TypeDefs@@ -65,7 +63,7 @@ B.length c `seq` do hClose h- return c -- hack: force reading whole file and close it immediately+ return c -- hack: force reading whole file and close it immediately -- | Serialize a value, optionally compress it, and write it to a file. -- In case of an error, the error message is issued and the arrow fails
src/Text/XML/HXT/Arrow/DocumentInput.hs view
@@ -15,8 +15,7 @@ -- ------------------------------------------------------------ module Text.XML.HXT.Arrow.DocumentInput- ( getURIContents- , getXmlContents+ ( getXmlContents , getXmlEntityContents , getEncoding , getTextEncoding@@ -25,30 +24,26 @@ ) where -import Control.Arrow -- arrow classes-import Control.Arrow.ArrowList+import Control.Arrow import Control.Arrow.ArrowIf-import Control.Arrow.ArrowTree import Control.Arrow.ArrowIO+import Control.Arrow.ArrowList+import Control.Arrow.ArrowTree import Control.Arrow.ListArrow -import Data.List ( isPrefixOf )-import Data.String.Unicode ( getDecodingFct- , guessEncoding- , normalizeNL- )+import Data.List (isPrefixOf)+import Data.String.Unicode (getDecodingFct,+ guessEncoding,+ normalizeNL) -import System.FilePath ( takeExtension )+import System.FilePath (takeExtension) -import qualified Text.XML.HXT.IO.GetFILE as FILE+import qualified Text.XML.HXT.IO.GetFILE as FILE import Text.XML.HXT.DOM.Interface -import Text.XML.HXT.Arrow.ParserInterface- ( parseXmlDocEncodingSpec- , parseXmlEntityEncodingSpec- , removeEncodingSpec- )+import Text.XML.HXT.Arrow.ParserInterface (parseXmlDocEncodingSpec, parseXmlEntityEncodingSpec,+ removeEncodingSpec) import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.Arrow.XmlState import Text.XML.HXT.Arrow.XmlState.TypeDefs@@ -59,6 +54,7 @@ protocolHandlers = [ ("file", getFileContents) , ("http", getHttpContents)+ , ("https", getHttpContents) , ("stdin", getStdinContents) ] @@ -171,35 +167,31 @@ getHttpContents = withoutUserState $ applyA $ getSysVar theHttpHandler -getURIContents :: IOStateArrow s XmlTree XmlTree-getURIContents- = getContentsFromString- `orElse`- getContentsFromDoc- where- getContentsFromString- = ( getAttrValue a_source- >>>- isA (isPrefixOf stringProtocol)- )- `guards`- getStringContents+getContentsFromString :: IOStateArrow s XmlTree XmlTree+getContentsFromString+ = ( getAttrValue a_source+ >>>+ isA (isPrefixOf stringProtocol)+ )+ `guards`+ getStringContents - getContentsFromDoc- = ( ( addTransferURI $< getBaseURI- >>>- getCont- )- `when`- ( setAbsURI $< ( getAttrValue a_source- >>^- ( \ src-> (if null src then "stdin:" else src) ) -- empty document name -> read from stdin- )- )- )+getContentsFromDoc :: IOStateArrow s XmlTree XmlTree+getContentsFromDoc+ = ( ( addTransferURI $< getBaseURI >>>- setDocumentStatusFromSystemState "getURIContents"-+ getCont+ )+ `when`+ ( setAbsURI $< ( getAttrValue a_source+ >>^+ ( \ src-> (if null src then "stdin:" else src) ) -- empty document name -> read from stdin+ )+ )+ )+ >>>+ setDocumentStatusFromSystemState "getContentsFromDoc"+ where setAbsURI src = ifA ( constA src >>> changeBaseURI ) this@@ -211,7 +203,7 @@ getCont = applyA ( getBaseURI -- compute the handler and call it >>>- traceValue 2 (("getURIContents: reading " ++) . show)+ traceValue 2 (("getContentsFromDoc: reading " ++) . show) >>> getSchemeFromURI >>>@@ -239,7 +231,7 @@ If the source name is empty, the input is read from standard input. The source is transformed into an absolute URI. If the source is a relative URI, or a file name,- it is expanded into an absolut URI with respect to the current base URI.+ it is expanded into an absolute URI with respect to the current base URI. The default base URI is of protocol \"file\" and points to the current working directory. The currently supported protocols are \"http\", \"file\", \"stdin\" and \"string\".@@ -262,7 +254,7 @@ getXmlEntityContents = traceMsg 2 "getXmlEntityContents" >>>- addAttr transferMimeType text_xml_external_parsed_entity -- the default transfer mimetype+ addAttr transferMimeType text_xml_external_parsed_entity -- the default transfer mimetype >>> getXmlContents' parseXmlEntityEncodingSpec >>>@@ -271,7 +263,7 @@ processChildren ( removeEncodingSpec >>>- changeText normalizeNL -- newline normalization must be done here+ changeText normalizeNL -- newline normalization must be done here ) -- the following calls of the parsers don't do this >>> setBaseURIFromDoc@@ -280,25 +272,28 @@ getXmlContents' :: IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree getXmlContents' parseEncodingSpec- = ( getURIContents- >>>- choiceA- [ isXmlHtmlDoc :-> ( parseEncodingSpec- >>>- filterErrorMsg- >>>- decodeDocument- )- , isTextDoc :-> decodeDocument- , this :-> this- ]- >>>- perform ( getAttrValue transferURI- >>>- traceValue 1 (("getXmlContents: content read and decoded for " ++) . show)- )- >>>- traceDoc "getXmlContents'"+ = ( getContentsFromString -- no decoding done for string: protocol+ `orElse`+ ( getContentsFromDoc+ >>>+ choiceA+ [ isXmlHtmlDoc :-> ( parseEncodingSpec+ >>>+ filterErrorMsg+ >>>+ decodeDocument+ )+ , isTextDoc :-> decodeDocument+ , this :-> this+ ]+ >>>+ perform ( getAttrValue transferURI+ >>>+ traceValue 1 (("getXmlContents: content read and decoded for " ++) . show)+ )+ >>>+ traceDoc "getXmlContents'"+ ) ) `when` isRoot
src/Text/XML/HXT/Arrow/DocumentOutput.hs view
@@ -24,45 +24,37 @@ ) 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 Control.Arrow+import Control.Arrow.ArrowExc+import Control.Arrow.ArrowIf+import Control.Arrow.ArrowIO+import Control.Arrow.ArrowList+import Control.Arrow.ArrowTree+import Control.Arrow.ListArrow -import qualified- Data.ByteString.Lazy as BS-import Data.Maybe-import Data.String.Unicode ( getOutputEncodingFct' )+import qualified Data.ByteString.Lazy as BS+import Data.Maybe+import Data.String.Unicode (getOutputEncodingFct') -import Text.XML.HXT.DOM.Interface-import qualified- Text.XML.HXT.DOM.ShowXml as XS+import Text.XML.HXT.DOM.Interface+import qualified Text.XML.HXT.DOM.ShowXml as XS -import Text.XML.HXT.Arrow.XmlArrow-import Text.XML.HXT.Arrow.Edit ( addHeadlineToXmlDoc- , addXmlPi- , addXmlPiEncoding- , indentDoc- , numberLinesInXmlDoc- , treeRepOfXmlDoc- , escapeHtmlRefs- , escapeXmlRefs- )-import Text.XML.HXT.Arrow.XmlState-import Text.XML.HXT.Arrow.XmlState.TypeDefs+import Text.XML.HXT.Arrow.Edit (addHeadlineToXmlDoc,+ addXmlPi,+ addXmlPiEncoding,+ escapeHtmlRefs,+ escapeXmlRefs, indentDoc,+ numberLinesInXmlDoc,+ treeRepOfXmlDoc)+import Text.XML.HXT.Arrow.XmlArrow+import Text.XML.HXT.Arrow.XmlState+import Text.XML.HXT.Arrow.XmlState.TypeDefs -import System.IO ( Handle- , IOMode(..)- , openFile- , openBinaryFile- , hSetBinaryMode- , hPutStrLn- , hClose- , stdout- )-import System.IO.Error ( try )+import System.IO (Handle, IOMode (..),+ hClose, hPutStrLn,+ hSetBinaryMode,+ openBinaryFile, openFile,+ stdout) -- ------------------------------------------------------------ --@@ -79,16 +71,15 @@ = ( if textMode then ( xshow getChildren >>>- arrIO (\ s -> try ( hPutDocument (\h -> hPutStrLn h s)))+ tryA (arrIO (\ s -> hPutDocument (\h -> hPutStrLn h s))) ) else ( xshowBlob getChildren >>>- arrIO (\ s -> try ( hPutDocument (\h -> do- BS.hPutStr h s- BS.hPutStr h (stringToBlob "\n")+ tryA (arrIO (\ s -> hPutDocument (\h -> do BS.hPutStr h s+ BS.hPutStr h (stringToBlob "\n") )- )- )+ )+ ) ) ) >>>@@ -221,7 +212,7 @@ encode :: String -> LA XmlTree XmlTree encode encodingScheme | encodingScheme == unicodeString- = replaceChildren+ = replaceChildren ( (getChildren >. XS.xshow'' cQuot aQuot) >>> mkText@@ -245,7 +236,7 @@ addAttr a_output_encoding encodingScheme where (cQuot, aQuot)- | quoteXml = escapeXmlRefs+ | quoteXml = escapeXmlRefs | otherwise = escapeHtmlRefs encodeFct = getOutputEncodingFct' encodingScheme@@ -256,7 +247,7 @@ mkBlob ) xshowBlobWithEnc cenc aenc enc f- = f >. XS.xshow' cenc aenc enc + = f >. XS.xshow' cenc aenc enc -- if encoding scheme is isolatin1 and the contents is a single blob (bytestring) -- the encoding is the identity.
src/Text/XML/HXT/Arrow/Edit.hs view
@@ -64,25 +64,25 @@ where import Control.Arrow-import Control.Arrow.ArrowList import Control.Arrow.ArrowIf+import Control.Arrow.ArrowList import Control.Arrow.ArrowTree import Control.Arrow.ListArrow import Control.Arrow.NTreeEdit -import Data.Char.Properties.XMLCharProps ( isXmlSpaceChar )+import Data.Char.Properties.XMLCharProps (isXmlSpaceChar) import Text.XML.HXT.Arrow.XmlArrow+import Text.XML.HXT.DOM.FormatXmlTree (formatXmlTree) import Text.XML.HXT.DOM.Interface-import qualified Text.XML.HXT.DOM.XmlNode as XN-import qualified Text.XML.HXT.DOM.ShowXml as XS-import Text.XML.HXT.DOM.FormatXmlTree ( formatXmlTree )-import Text.XML.HXT.Parser.HtmlParsec ( emptyHtmlTags )-import Text.XML.HXT.Parser.XmlEntities ( xmlEntities )-import Text.XML.HXT.Parser.XhtmlEntities ( xhtmlEntities )+import qualified Text.XML.HXT.DOM.ShowXml as XS+import qualified Text.XML.HXT.DOM.XmlNode as XN+import Text.XML.HXT.Parser.HtmlParsec (emptyHtmlTags)+import Text.XML.HXT.Parser.XhtmlEntities (xhtmlEntities)+import Text.XML.HXT.Parser.XmlEntities (xmlEntities) -import Data.List ( isPrefixOf )-import qualified Data.Map as M+import Data.List (isPrefixOf)+import qualified Data.Map as M import Data.Maybe -- ------------------------------------------------------------@@ -108,10 +108,12 @@ canonicalizeTree' :: LA XmlTree XmlTree -> LA XmlTree XmlTree canonicalizeTree' toBeRemoved- = processChildren- ( (none `when` (isText <+> isXmlPi)) -- remove XML PI and all text around XML root element- >>>- (deep isPi `when` isDTD) -- remove DTD parts, except PIs whithin DTD+ = ( processChildren+ ( (none `when` (isText <+> isXmlPi)) -- remove XML PI and all text around XML root element+ >>>+ (deep isPi `when` isDTD) -- remove DTD parts, except PIs whithin DTD+ )+ `when` isRoot ) >>> canonicalizeNodes toBeRemoved@@ -278,7 +280,7 @@ -- ------------------------------------------------------------ -substXHTMLEntityRef :: LA XmlTree XmlTree+substXHTMLEntityRef :: LA XmlTree XmlTree substXHTMLEntityRef = ( getEntityRef >>>@@ -291,7 +293,7 @@ subst name = maybe [] (:[]) $ M.lookup name xhtmlEntitySubstTable -substAllXHTMLEntityRefs :: ArrowXml a => a XmlTree XmlTree+substAllXHTMLEntityRefs :: ArrowXml a => a XmlTree XmlTree substAllXHTMLEntityRefs = fromLA $ processBottomUp substXHTMLEntityRef
src/Text/XML/HXT/Arrow/ParserInterface.hs view
@@ -35,9 +35,12 @@ parseXmlDTDPart :: ArrowXml a => a (String, XmlTree) XmlTree parseXmlDTDPart = arr2L XP.parseXmlDTDPart -parseXmlContent :: ArrowXml a => a String XmlTree-parseXmlContent = arrL XP.xread+xreadCont :: ArrowXml a => a String XmlTree+xreadCont = arrL XP.xread +xreadDoc :: ArrowXml a => a String XmlTree+xreadDoc = arrL XP.xreadDoc+ parseXmlEntityEncodingSpec , parseXmlDocEncodingSpec , removeEncodingSpec :: ArrowXml a => a XmlTree XmlTree@@ -67,7 +70,10 @@ parseHtmlDoc :: ArrowList a => a (String, String) XmlTree parseHtmlDoc = arr2L HP.parseHtmlDocument -parseHtmlContent :: ArrowList a => a String XmlTree-parseHtmlContent = arrL HP.parseHtmlContent+hread :: ArrowList a => a String XmlTree+hread = arrL HP.parseHtmlContent++hreadDoc :: ArrowList a => a String XmlTree+hreadDoc = arrL $ HP.parseHtmlDocument "string" -- ------------------------------------------------------------
src/Text/XML/HXT/Arrow/Pickle.hs view
@@ -15,7 +15,7 @@ This module is an adaptation of the pickler combinators developed by Andrew Kennedy-( http:\/\/research.microsoft.com\/~akenn\/fun\/picklercombinators.pdf )+( https:\/\/www.microsoft.com\/en-us\/research\/wp-content\/uploads\/2004\/01\/picklercombinators.pdf ) The difference to Kennedys approach is that the target is not a list of Chars but a list of XmlTrees. The basic picklers will@@ -49,10 +49,11 @@ -- from Text.XML.HXT.Arrow.Pickle.Xml , pickleDoc , unpickleDoc+ , unpickleDoc' , showPickled , PU(..)- , XmlPickler+ , XmlPickler(..) , xp4Tuple , xp5Tuple@@ -77,18 +78,26 @@ , xp24Tuple , xpAddFixedAttr+ , xpAddNSDecl , xpAlt , xpAttr- , xpTextAttr , xpAttrFixed , xpAttrImplied+ , xpAttrNS+ , xpCheckEmpty+ , xpCheckEmptyAttributes+ , xpCheckEmptyContents+ , xpTextAttr , xpChoice- , xpCondSeq , xpDefault , xpElem+ , xpElemNS , xpElemWithAttrValue- , xpickle+ , xpFilterAttr+ , xpFilterCont+ , xpInt , xpLift+ , xpLiftEither , xpLiftMaybe , xpList , xpList1@@ -96,8 +105,8 @@ , xpOption , xpPair , xpPrim- , xpInt , xpSeq+ , xpSeq' , xpText , xpText0 , xpTextDT@@ -107,6 +116,7 @@ , xpTriple , xpUnit , xpWrap+ , xpWrapEither , xpWrapMaybe , xpXmlText , xpZero@@ -118,8 +128,6 @@ ) where -import Data.Maybe- import Control.Arrow.ListArrows import Text.XML.HXT.DOM.Interface@@ -233,13 +241,7 @@ >>> readFromString [withValidate True] >>>- ( xunpickleVal xp- `orElse`- ( issueErr "unpickling the document failed"- >>>- none- )- )+ xunpickleVal xp ) &&& this@@ -257,6 +259,7 @@ -- | The arrow version of the unpickler function +{- old version, runs outside IO xunpickleVal :: ArrowXml a => PU b -> a XmlTree b xunpickleVal xp = ( processChildren (none `whenNot` isElem) -- remove all stuff surrounding the root element `when`@@ -264,6 +267,23 @@ ) >>> arrL (maybeToList . unpickleDoc xp)+-- -}++xunpickleVal :: PU b -> IOStateArrow s XmlTree b+xunpickleVal xp = ( processChildren (none `whenNot` isElem) -- remove all stuff surrounding the root element+ `when`+ isRoot+ )+ >>>+ arr (unpickleDoc' xp)+ >>>+ ( ( (issueFatal $< arr ("document unpickling failed\n" ++))+ >>>+ none+ )+ |||+ this+ ) -- | Compute the associated DTD of a pickler
src/Text/XML/HXT/Arrow/Pickle/Xml.hs view
@@ -1,951 +1,1518 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-}---- --------------------------------------------------------------{- |- Module : Text.XML.HXT.Arrow.Pickle.Xml- Copyright : Copyright (C) 2005-2008 Uwe Schmidt- License : MIT-- Maintainer : Uwe Schmidt (uwe@fh-wedel.de)- Stability : experimental- Portability: portable-- Pickler functions for converting between user defined data types- and XmlTree data. Usefull for persistent storage and retreival- of arbitray data as XML documents-- This module is an adaptation of the pickler combinators- developed by Andrew Kennedy- ( http:\/\/research.microsoft.com\/~akenn\/fun\/picklercombinators.pdf )-- The difference to Kennedys approach is that the target is not- a list of Chars but a list of XmlTrees. The basic picklers will- convert data into XML text nodes. New are the picklers for- creating elements and attributes.-- One extension was neccessary: The unpickling may fail.- Therefore the unpickler has a Maybe result type.- Failure is used to unpickle optional elements- (Maybe data) and lists of arbitray length-- There is an example program demonstrating the use- of the picklers for a none trivial data structure.- (see \"examples\/arrows\/pickle\" directory)---}---- --------------------------------------------------------------module Text.XML.HXT.Arrow.Pickle.Xml-where--import Control.Arrow.ListArrows--import Data.Char (isDigit)-import Data.List (foldl')-import Data.Maybe-import Data.Map (Map)-import qualified Data.Map as M--import Text.XML.HXT.DOM.Interface-import qualified Text.XML.HXT.DOM.XmlNode as XN--import Text.XML.HXT.Arrow.Edit (xshowEscapeXml)-import Text.XML.HXT.Arrow.Pickle.Schema-import Text.XML.HXT.Arrow.ReadDocument (xread)-import Text.XML.HXT.Arrow.WriteDocument (writeDocumentToString)-import Text.XML.HXT.Arrow.XmlArrow-import Text.XML.HXT.Arrow.XmlState---- --------------------------------------------------------------data St = St { attributes :: [XmlTree]- , contents :: [XmlTree]- }--data PU a = PU { appPickle :: (a, St) -> St- , appUnPickle :: St -> (Maybe a, St)- , theSchema :: Schema- }--emptySt :: St-emptySt = St { attributes = []- , contents = []- }--addAtt :: XmlTree -> St -> St-addAtt x s = s {attributes = x : attributes s}--addCont :: XmlTree -> St -> St-addCont x s = s {contents = x : contents s}--dropCont :: St -> St-dropCont s = s { contents = drop 1 (contents s) }--getAtt :: QName -> St -> Maybe XmlTree-getAtt qn s- = listToMaybe $- runLA ( arrL attributes- >>>- isAttr >>> hasQName qn- ) s--getCont :: St -> Maybe XmlTree-getCont s = listToMaybe . contents $ s---- ---------------------------------------------------------------- | conversion of an arbitrary value into an XML document tree.------ The pickler, first parameter, controls the conversion process.--- Result is a complete document tree including a root node--pickleDoc :: PU a -> a -> XmlTree-pickleDoc p v- = XN.mkRoot (attributes st) (contents st)- where- st = appPickle p (v, emptySt)---- | Conversion of an XML document tree into an arbitrary data type------ The inverse of 'pickleDoc'.--- This law should hold for all picklers: @ unpickle px . pickle px $ v == Just v @.--- Not every possible combination of picklers make sense.--- For reconverting a value from an XML tree, is becomes neccessary,--- to introduce \"enough\" markup for unpickling the value--unpickleDoc :: PU a -> XmlTree -> Maybe a-unpickleDoc p t- | XN.isRoot t- = fst . appUnPickle p $ St { attributes = fromJust . XN.getAttrl $ t- , contents = XN.getChildren t- }- | otherwise- = unpickleDoc p (XN.mkRoot [] [t])---- ---------------------------------------------------------------- | Pickles a value, then writes the document to a string.--showPickled :: (XmlPickler a) => SysConfigList -> a -> String-showPickled a = concat . (pickleDoc xpickle >>> runLA (writeDocumentToString a))---- ---------------------------------------------------------------- | The zero pickler------ Encodes nothing, fails always during unpickling--xpZero :: PU a-xpZero = PU { appPickle = snd- , appUnPickle = \ s -> (Nothing, s)- , theSchema = scNull- }---- unit pickler--xpUnit :: PU ()-xpUnit = xpLift ()---- | Lift a value to a pickler------ When pickling, nothing is encoded, when unpickling, the given value is inserted.--- This pickler always succeeds.--xpLift :: a -> PU a-xpLift x = PU { appPickle = snd- , appUnPickle = \ s -> (Just x, s)- , theSchema = scEmpty- }---- | Lift a Maybe value to a pickler.------ @Nothing@ is mapped to the zero pickler, @Just x@ is pickled with @xpLift x@.--xpLiftMaybe :: Maybe a -> PU a-xpLiftMaybe v = (xpLiftMaybe' v) { theSchema = scOption scEmpty }- where- xpLiftMaybe' Nothing = xpZero- xpLiftMaybe' (Just x) = xpLift x----- | pickle\/unpickle combinator for sequence and choice.------ When the first unpickler fails,--- the second one is taken, else the third one configured with the result from the first--- is taken. This pickler is a generalisation for 'xpSeq' and 'xpChoice' .------ The schema must be attached later, e.g. in xpPair or other higher level combinators--xpCondSeq :: PU b -> (b -> a) -> PU a -> (a -> PU b) -> PU b-xpCondSeq pd f pa k- = PU { appPickle = ( \ (b, s) ->- let- a = f b- pb = k a- in- appPickle pa (a, (appPickle pb (b, s)))- )- , appUnPickle = ( \ s ->- let- (a, s') = appUnPickle pa s- in- case a of- Nothing -> appUnPickle pd s- Just a' -> appUnPickle (k a') s'- )- , theSchema = undefined- }----- | Combine two picklers sequentially.------ If the first fails during--- unpickling, the whole unpickler fails--xpSeq :: (b -> a) -> PU a -> (a -> PU b) -> PU b-xpSeq = xpCondSeq xpZero----- | combine tow picklers with a choice------ Run two picklers in sequence like with xpSeq.--- When during unpickling the first one fails,--- an alternative pickler (first argument) is applied.--- This pickler is only used as combinator for unpickling.--xpChoice :: PU b -> PU a -> (a -> PU b) -> PU b-xpChoice pb = xpCondSeq pb undefined----- | map value into another domain and apply pickler there------ One of the most often used picklers.--xpWrap :: (a -> b, b -> a) -> PU a -> PU b-xpWrap (i, j) pa = (xpSeq j pa (xpLift . i)) { theSchema = theSchema pa }---- | like 'xpWrap', but if the inverse mapping is undefined, the unpickler fails------ Map a value into another domain. If the inverse mapping is--- undefined (Nothing), the unpickler fails--xpWrapMaybe :: (a -> Maybe b, b -> a) -> PU a -> PU b-xpWrapMaybe (i, j) pa = (xpSeq j pa (xpLiftMaybe . i)) { theSchema = theSchema pa }---- ---------------------------------------------------------------- | pickle a pair of values sequentially------ Used for pairs or together with wrap for pickling--- algebraic data types with two components--xpPair :: PU a -> PU b -> PU (a, b)-xpPair pa pb- = ( xpSeq fst pa (\ a ->- xpSeq snd pb (\ b ->- xpLift (a,b)))- ) { theSchema = scSeq (theSchema pa) (theSchema pb) }---- | Like 'xpPair' but for triples--xpTriple :: PU a -> PU b -> PU c -> PU (a, b, c)-xpTriple pa pb pc- = xpWrap (toTriple, fromTriple) (xpPair pa (xpPair pb pc))- where- toTriple ~(a, ~(b, c)) = (a, b, c )- fromTriple ~(a, b, c ) = (a, (b, c))---- | Like 'xpPair' and 'xpTriple' but for 4-tuples--xp4Tuple :: PU a -> PU b -> PU c -> PU d -> PU (a, b, c, d)-xp4Tuple pa pb pc pd- = xpWrap (toQuad, fromQuad) (xpPair pa (xpPair pb (xpPair pc pd)))- where- toQuad ~(a, ~(b, ~(c, d))) = (a, b, c, d )- fromQuad ~(a, b, c, d ) = (a, (b, (c, d)))---- | Like 'xpPair' and 'xpTriple' but for 5-tuples--xp5Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> PU (a, b, c, d, e)-xp5Tuple pa pb pc pd pe- = xpWrap (toQuint, fromQuint) (xpPair pa (xpPair pb (xpPair pc (xpPair pd pe))))- where- toQuint ~(a, ~(b, ~(c, ~(d, e)))) = (a, b, c, d, e )- fromQuint ~(a, b, c, d, e ) = (a, (b, (c, (d, e))))---- | Like 'xpPair' and 'xpTriple' but for 6-tuples--xp6Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> PU f -> PU (a, b, c, d, e, f)-xp6Tuple pa pb pc pd pe pf- = xpWrap (toSix, fromSix) (xpPair pa (xpPair pb (xpPair pc (xpPair pd (xpPair pe pf)))))- where- toSix ~(a, ~(b, ~(c, ~(d, ~(e, f))))) = (a, b, c, d, e, f )- fromSix ~(a, b, c, d, e, f) = (a, (b, (c, (d, (e, f)))))---- ---------------------------------------------------------------- | Like 'xpPair' and 'xpTriple' but for 7-tuples------ Thanks to Tony Morris for doing xp7Tuple, ..., xp24Tuple.--xp7Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->- PU f -> PU g -> PU (a, b, c, d, e, f, g)-xp7Tuple a b c d e f g- = xpWrap ( \ (a, (b, c, d, e, f, g)) -> (a, b, c, d, e, f, g)- , \ (a, b, c, d, e, f, g) -> (a, (b, c, d, e, f, g))- )- (xpPair a (xp6Tuple b c d e f g))--xp8Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->- PU f -> PU g -> PU h -> PU (a, b, c, d, e, f, g, h)-xp8Tuple a b c d e f g h- = xpWrap ( \ ((a, b), (c, d, e, f, g, h)) -> (a, b, c, d, e, f, g, h)- , \ (a, b, c, d, e, f, g, h) -> ((a, b), (c, d, e, f, g, h))- )- (xpPair (xpPair a b) (xp6Tuple c d e f g h))--xp9Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->- PU f -> PU g -> PU h -> PU i -> PU (a, b, c, d, e, f, g, h, i)-xp9Tuple a b c d e f g h i- = xpWrap ( \ ((a, b, c), (d, e, f, g, h, i)) -> (a, b, c, d, e, f, g, h, i)- , \ (a, b, c, d, e, f, g, h, i) -> ((a, b, c), (d, e, f, g, h, i))- )- (xpPair (xpTriple a b c) (xp6Tuple d e f g h i))--xp10Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->- PU f -> PU g -> PU h -> PU i -> PU j ->- PU (a, b, c, d, e, f, g, h, i, j)-xp10Tuple a b c d e f g h i j- = xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j)) -> (a, b, c, d, e, f, g, h, i, j)- , \ (a, b, c, d, e, f, g, h, i, j) -> ((a, b, c, d), (e, f, g, h, i, j))- )- (xpPair (xp4Tuple a b c d) (xp6Tuple e f g h i j))--xp11Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->- PU f -> PU g -> PU h -> PU i -> PU j ->- PU k -> PU (a, b, c, d, e, f, g, h, i, j, k)-xp11Tuple a b c d e f g h i j k- = xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k)) -> (a, b, c, d, e, f, g, h, i, j, k)- , \ (a, b, c, d, e, f, g, h, i, j, k) -> ((a, b, c, d, e), (f, g, h, i, j, k))- )- (xpPair (xp5Tuple a b c d e) (xp6Tuple f g h i j k))--xp12Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->- PU f -> PU g -> PU h -> PU i -> PU j ->- PU k -> PU l -> PU (a, b, c, d, e, f, g, h, i, j, k, l)-xp12Tuple a b c d e f g h i j k l- = xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l)) -> (a, b, c, d, e, f, g, h, i, j, k, l)- , \ (a, b, c, d, e, f, g, h, i, j, k, l) -> ((a, b, c, d, e, f), (g, h, i, j, k, l))- )- (xpPair (xp6Tuple a b c d e f) (xp6Tuple g h i j k l))--xp13Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->- PU f -> PU g -> PU h -> PU i -> PU j ->- PU k -> PU l -> PU m -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m)-xp13Tuple a b c d e f g h i j k l m- = xpWrap ( \ (a, (b, c, d, e, f, g), (h, i, j, k, l, m)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m)- , \ (a, b, c, d, e, f, g, h, i, j, k, l, m) -> (a, (b, c, d, e, f, g), (h, i, j, k, l, m))- )- (xpTriple a (xp6Tuple b c d e f g) (xp6Tuple h i j k l m))--xp14Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->- PU f -> PU g -> PU h -> PU i -> PU j ->- PU k -> PU l -> PU m -> PU n -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n)-xp14Tuple a b c d e f g h i j k l m n- = xpWrap ( \ ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n)- , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -> ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n))- )- (xpTriple (xpPair a b) (xp6Tuple c d e f g h) (xp6Tuple i j k l m n))--xp15Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->- PU f -> PU g -> PU h -> PU i -> PU j ->- PU k -> PU l -> PU m -> PU n -> PU o ->- PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)-xp15Tuple a b c d e f g h i j k l m n o- = xpWrap ( \ ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)- , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -> ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o))- )- (xpTriple (xpTriple a b c) (xp6Tuple d e f g h i) (xp6Tuple j k l m n o))--xp16Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->- PU f -> PU g -> PU h -> PU i -> PU j ->- PU k -> PU l -> PU m -> PU n -> PU o ->- PU p -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)-xp16Tuple a b c d e f g h i j k l m n o p- = xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)- , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) -> ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p))- )- (xpTriple (xp4Tuple a b c d) (xp6Tuple e f g h i j) (xp6Tuple k l m n o p))--xp17Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->- PU f -> PU g -> PU h -> PU i -> PU j ->- PU k -> PU l -> PU m -> PU n -> PU o ->- PU p -> PU q -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q)-xp17Tuple a b c d e f g h i j k l m n o p q- = xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q)- , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) -> ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q))- )- (xpTriple (xp5Tuple a b c d e) (xp6Tuple f g h i j k) (xp6Tuple l m n o p q))--xp18Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->- PU f -> PU g -> PU h -> PU i -> PU j ->- PU k -> PU l -> PU m -> PU n -> PU o ->- PU p -> PU q -> PU r -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r)-xp18Tuple a b c d e f g h i j k l m n o p q r- = xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r)- , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) -> ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r))- )- (xpTriple (xp6Tuple a b c d e f) (xp6Tuple g h i j k l) (xp6Tuple m n o p q r))--xp19Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->- PU f -> PU g -> PU h -> PU i -> PU j ->- PU k -> PU l -> PU m -> PU n -> PU o ->- PU p -> PU q -> PU r -> PU s -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s)-xp19Tuple a b c d e f g h i j k l m n o p q r s- = xpWrap ( \ (a, (b, c, d, e, f, g), (h, i, j, k, l, m), (n, o, p, q, r, s)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s)- , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) -> (a, (b, c, d, e, f, g), (h, i, j, k, l, m), (n, o, p, q, r, s))- )- (xp4Tuple a (xp6Tuple b c d e f g) (xp6Tuple h i j k l m) (xp6Tuple n o p q r s))--xp20Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->- PU f -> PU g -> PU h -> PU i -> PU j ->- PU k -> PU l -> PU m -> PU n -> PU o ->- PU p -> PU q -> PU r -> PU s -> PU t ->- PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t)-xp20Tuple a b c d e f g h i j k l m n o p q r s t- = xpWrap ( \ ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n), (o, p, q, r, s, t)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t)- , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) -> ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n), (o, p, q, r, s, t))- )- (xp4Tuple (xpPair a b) (xp6Tuple c d e f g h) (xp6Tuple i j k l m n) (xp6Tuple o p q r s t))--xp21Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->- PU f -> PU g -> PU h -> PU i -> PU j ->- PU k -> PU l -> PU m -> PU n -> PU o ->- PU p -> PU q -> PU r -> PU s -> PU t ->- PU u -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u)-xp21Tuple a b c d e f g h i j k l m n o p q r s t u- = xpWrap ( \ ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o), (p, q, r, s, t, u)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u)- , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) -> ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o), (p, q, r, s, t, u))- )- (xp4Tuple (xpTriple a b c) (xp6Tuple d e f g h i) (xp6Tuple j k l m n o) (xp6Tuple p q r s t u))--xp22Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->- PU f -> PU g -> PU h -> PU i -> PU j ->- PU k -> PU l -> PU m -> PU n -> PU o ->- PU p -> PU q -> PU r -> PU s -> PU t ->- PU u -> PU v -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v)-xp22Tuple a b c d e f g h i j k l m n o p q r s t u v- = xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p), (q, r, s, t, u, v)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v)- , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) -> ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p), (q, r, s, t, u, v))- )- (xp4Tuple (xp4Tuple a b c d) (xp6Tuple e f g h i j) (xp6Tuple k l m n o p) (xp6Tuple q r s t u v))--xp23Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->- PU f -> PU g -> PU h -> PU i -> PU j ->- PU k -> PU l -> PU m -> PU n -> PU o ->- PU p -> PU q -> PU r -> PU s -> PU t ->- PU u -> PU v -> PU w -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w)-xp23Tuple a b c d e f g h i j k l m n o p q r s t u v w- = xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q), (r, s, t, u, v, w)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w)- , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) -> ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q), (r, s, t, u, v, w))- )- (xp4Tuple (xp5Tuple a b c d e) (xp6Tuple f g h i j k) (xp6Tuple l m n o p q) (xp6Tuple r s t u v w))---- | Hopefully no one needs a xp25Tuple--xp24Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->- PU f -> PU g -> PU h -> PU i -> PU j ->- PU k -> PU l -> PU m -> PU n -> PU o ->- PU p -> PU q -> PU r -> PU s -> PU t ->- PU u -> PU v -> PU w -> PU x -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x)-xp24Tuple a b c d e f g h i j k l m n o p q r s t u v w x- = xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r), (s, t, u, v, w, x)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x)- , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) -> ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r), (s, t, u, v, w, x))- )- (xp4Tuple (xp6Tuple a b c d e f) (xp6Tuple g h i j k l) (xp6Tuple m n o p q r) (xp6Tuple s t u v w x))---- ----------------------------------------------------------------- | Pickle a string into an XML text node------ One of the most often used primitive picklers. Attention:--- For pickling empty strings use 'xpText0'. If the text has a more--- specific datatype than xsd:string, use 'xpTextDT'--xpText :: PU String-xpText = xpTextDT scString1-{-# INLINE xpText #-}---- | Pickle a string into an XML text node------ Text pickler with a description of the structure of the text--- by a schema. A schema for a data type can be defined by 'Text.XML.HXT.Arrow.Pickle.Schema.scDT'.--- In 'Text.XML.HXT.Arrow.Pickle.Schema' there are some more functions for creating--- simple datatype descriptions.--xpTextDT :: Schema -> PU String-xpTextDT sc- = PU { appPickle = \ (s, st) -> addCont (XN.mkText s) st- , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleString st)- , theSchema = sc- }- where- unpickleString st- = do- t <- getCont st- s <- XN.getText t- return (Just s, dropCont st)---- | Pickle a possibly empty string into an XML node.------ Must be used in all places, where empty strings are legal values.--- If the content of an element can be an empty string, this string disapears--- during storing the DOM into a document and reparse the document.--- So the empty text node becomes nothing, and the pickler must deliver an empty string,--- if there is no text node in the document.--xpText0 :: PU String-xpText0 = xpText0DT scString1-{-# INLINE xpText0 #-}---- | Pickle a possibly empty string with a datatype description into an XML node.------ Like 'xpText0' but with extra Parameter for datatype description as in 'xpTextDT'.--xpText0DT :: Schema -> PU String-xpText0DT sc- = xpWrap (fromMaybe "", emptyToNothing) $ xpOption $ xpTextDT sc- where- emptyToNothing "" = Nothing- emptyToNothing x = Just x---- | Pickle an arbitrary value by applyling show during pickling--- and read during unpickling.------ Real pickling is then done with 'xpText'.--- One of the most often used pimitive picklers. Applicable for all--- types which are instances of @Read@ and @Show@--xpPrim :: (Read a, Show a) => PU a-xpPrim- = xpWrapMaybe (readMaybe, show) xpText- where- readMaybe :: Read a => String -> Maybe a- readMaybe str- = val (reads str)- where- val [(x,"")] = Just x- val _ = Nothing---- | Pickle an unsigned -xpInt :: PU Int-xpInt- = xpWrapMaybe (readMaybe, show) xpText- where- readMaybe xs- | all isDigit xs = Just . foldl' (\ r c -> 10 * r + (fromEnum c - fromEnum '0')) 0 $ xs- readMaybe ('-' : xs) = fmap (0 -) . readMaybe $ xs- readMaybe ('+' : xs) = readMaybe $ xs- readMaybe _ = Nothing---- ---------------------------------------------------------------- | Pickle an XmlTree by just adding it------ Usefull for components of type XmlTree in other data structures--xpTree :: PU XmlTree-xpTree = PU { appPickle = \ (s, st) -> addCont s st- , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleTree st)- , theSchema = Any- }- where- unpickleTree st- = do- t <- getCont st- return (Just t, dropCont st)---- | Pickle a whole list of XmlTrees by just adding the list, unpickle is done by taking all element contents.------ This pickler should always be combined with 'xpElem' for taking the whole contents of an element.--xpTrees :: PU [XmlTree]-xpTrees = (xpList xpTree) { theSchema = Any }---- | Pickle a string representing XML contents by inserting the tree representation into the XML document.------ Unpickling is done by converting the contents with--- 'Text.XML.HXT.Arrow.Edit.xshowEscapeXml' into a string,--- this function will escape all XML special chars, such that pickling the value back becomes save.--- Pickling is done with 'Text.XML.HXT.Arrow.ReadDocument.xread'--xpXmlText :: PU String-xpXmlText- = xpWrap ( showXML, readXML ) $ xpTrees- where- showXML = concat . runLA ( xshowEscapeXml unlistA )- readXML = runLA xread---- ---------------------------------------------------------------- | Encoding of optional data by ignoring the Nothing case during pickling--- and relying on failure during unpickling to recompute the Nothing case------ The default pickler for Maybe types--xpOption :: PU a -> PU (Maybe a)-xpOption pa- = PU { appPickle = ( \ (a, st) ->- case a of- Nothing -> st- Just x -> appPickle pa (x, st)- )-- , appUnPickle = appUnPickle $- xpChoice (xpLift Nothing) pa (xpLift . Just)-- , theSchema = scOption (theSchema pa)- }---- | Optional conversion with default value------ The default value is not encoded in the XML document,--- during unpickling the default value is inserted if the pickler fails--xpDefault :: (Eq a) => a -> PU a -> PU a-xpDefault df- = xpWrap ( fromMaybe df- , \ x -> if x == df then Nothing else Just x- ) .- xpOption---- ---------------------------------------------------------------- | Encoding of list values by pickling all list elements sequentially.------ Unpickler relies on failure for detecting the end of the list.--- The standard pickler for lists. Can also be used in combination with 'xpWrap'--- for constructing set and map picklers--xpList :: PU a -> PU [a]-xpList pa- = PU { appPickle = ( \ (a, st) ->- case a of- [] -> st- _:_ -> appPickle pc (a, st)- )- , appUnPickle = appUnPickle $- xpChoice (xpLift []) pa- (\ x -> xpSeq id (xpList pa) (\xs -> xpLift (x:xs)))-- , theSchema = scList (theSchema pa)- }- where- pc = xpSeq head pa (\ x ->- xpSeq tail (xpList pa) (\ xs ->- xpLift (x:xs)))---- | Encoding of a none empty list of values------ Attention: when calling this pickler with an empty list,--- an internal error \"head of empty list is raised\".--xpList1 :: PU a -> PU [a]-xpList1 pa- = ( xpWrap (\ (x, xs) -> x : xs- ,\ x -> (head x, tail x)- ) $- xpPair pa (xpList pa)- ) { theSchema = scList1 (theSchema pa) }---- ---------------------------------------------------------------- | Standard pickler for maps------ This pickler converts a map into a list of pairs.--- All key value pairs are mapped to an element with name (1.arg),--- the key is encoded as an attribute named by the 2. argument,--- the 3. arg is the pickler for the keys, the last one for the values--xpMap :: Ord k => String -> String -> PU k -> PU v -> PU (Map k v)-xpMap en an xpk xpv- = xpWrap ( M.fromList- , M.toList- ) $- xpList $- xpElem en $- xpPair ( xpAttr an $ xpk ) xpv----- ---------------------------------------------------------------- | Pickler for sum data types.------ Every constructor is mapped to an index into the list of picklers.--- The index is used only during pickling, not during unpickling, there the 1. match is taken--xpAlt :: (a -> Int) -> [PU a] -> PU a-xpAlt tag ps- = PU { appPickle = ( \ (a, st) ->- let- pa = ps !! (tag a)- in- appPickle pa (a, st)- )- , appUnPickle = appUnPickle $- ( case ps of- [] -> xpZero- pa:ps1 -> xpChoice (xpAlt tag ps1) pa xpLift- )- , theSchema = scAlts (map theSchema ps)- }---- ---------------------------------------------------------------- | Pickler for wrapping\/unwrapping data into an XML element------ Extra parameter is the element name given as a QName. THE pickler for constructing--- nested structures------ Example:------ > xpElemQN (mkName "number") $ xpickle------ will map an (42::Int) onto------ > <number>42</number>--xpElemQN :: QName -> PU a -> PU a-xpElemQN qn pa- = PU { appPickle = ( \ (a, st) ->- let- st' = appPickle pa (a, emptySt)- in- addCont (XN.mkElement qn (attributes st') (contents st')) st- )- , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleElement st)- , theSchema = scElem (qualifiedName qn) (theSchema pa)- }- where- unpickleElement st- = do- t <- getCont st- n <- XN.getElemName t- if n /= qn- then fail ("element name " ++ show n ++ " does not match" ++ show qn)- else do- let cs = XN.getChildren t- al <- XN.getAttrl t- res <- fst . appUnPickle pa $ St {attributes = al, contents = cs}- return (Just res, dropCont st)---- | convenient Pickler for xpElemQN------ > xpElem n = xpElemQN (mkName n)--xpElem :: String -> PU a -> PU a-xpElem = xpElemQN . mkName---- ---------------------------------------------------------------- | Pickler for wrapping\/unwrapping data into an XML element with an attribute with given value------ To make XML structures flexible but limit the number of different elements, it's sometimes--- useful to use a kind of generic element with a key value structure------ Example:------ > <attr name="key1">value1</attr>--- > <attr name="key2">value2</attr>--- > <attr name="key3">value3</attr>------ the Haskell datatype may look like this------ > type T = T { key1 :: Int ; key2 :: String ; key3 :: Double }------ Then the picker for that type looks like this------ > xpT :: PU T--- > xpT = xpWrap ( uncurry3 T, \ t -> (key1 t, key2 t, key3 t) ) $--- > xpTriple (xpElemWithAttrValue "attr" "name" "key1" $ xpickle)--- > (xpElemWithAttrValue "attr" "name" "key2" $ xpText0)--- > (xpElemWithAttrValue "attr" "name" "key3" $ xpickle)--xpElemWithAttrValue :: String -> String -> String -> PU a -> PU a-xpElemWithAttrValue name an av pa- = PU { appPickle = ( \ (a, st) ->- let- st' = appPickle pa' (a, emptySt)- in- addCont (XN.mkElement (mkName name) (attributes st') (contents st')) st- )- , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleElement st)- , theSchema = scElem name (theSchema pa')- }- where- pa' = xpAddFixedAttr an av $ pa- noMatch = null . runLA ( isElem- >>>- hasName name- >>>- hasAttrValue an (==av)- )- unpickleElement st- = do- t <- getCont st- if noMatch t- then fail "element name or attr value does not match"- else do- let cs = XN.getChildren t- al <- XN.getAttrl t- res <- fst . appUnPickle pa $ St {attributes = al, contents = cs}- return (Just res, dropCont st)---- ---------------------------------------------------------------- | Pickler for storing\/retreiving data into\/from an attribute value------ The attribute is inserted in the surrounding element constructed by the 'xpElem' pickler--xpAttrQN :: QName -> PU a -> PU a-xpAttrQN qn pa- = PU { appPickle = ( \ (a, st) ->- let- st' = appPickle pa (a, emptySt)- in- addAtt (XN.mkAttr qn (contents st')) st- )- , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleAttr st)- , theSchema = scAttr (qualifiedName qn) (theSchema pa)- }- where- unpickleAttr st- = do- a <- getAtt qn st- let av = XN.getChildren a- res <- fst . appUnPickle pa $ St {attributes = [], contents = av}- return (Just res, st) -- attribute is not removed from attribute list,- -- attributes are selected by name---- | convenient Pickler for xpAttrQN------ > xpAttr n = xpAttrQN (mkName n)--xpAttr :: String -> PU a -> PU a-xpAttr = xpAttrQN . mkName---- | A text attribute.-xpTextAttr :: String -> PU String-xpTextAttr = flip xpAttr xpText---- | Add an optional attribute for an optional value (Maybe a).--xpAttrImplied :: String -> PU a -> PU (Maybe a)-xpAttrImplied name pa- = xpOption $ xpAttr name pa--xpAttrFixed :: String -> String -> PU ()-xpAttrFixed name val- = ( xpWrapMaybe ( \ v -> if v == val then Just () else Nothing- , const val- ) $- xpAttr name xpText- ) { theSchema = scAttr name (scFixed val) }---- | Add an attribute with a fixed value.------ Useful e.g. to declare namespaces. Is implemented by 'xpAttrFixed'--xpAddFixedAttr :: String -> String -> PU a -> PU a-xpAddFixedAttr name val pa- = xpWrap ( snd- , (,) ()- ) $- xpPair (xpAttrFixed name val) pa---- ---------------------------------------------------------------- | The class for overloading 'xpickle', the default pickler--class XmlPickler a where- xpickle :: PU a--instance XmlPickler Int where- xpickle = xpPrim--instance XmlPickler Integer where- xpickle = xpPrim--{-- no instance of XmlPickler Char- because then every text would be encoded- char by char, because of the instance for lists--instance XmlPickler Char where- xpickle = xpPrim--}--instance XmlPickler () where- xpickle = xpUnit--instance (XmlPickler a, XmlPickler b) => XmlPickler (a,b) where- xpickle = xpPair xpickle xpickle--instance (XmlPickler a, XmlPickler b, XmlPickler c) => XmlPickler (a,b,c) where- xpickle = xpTriple xpickle xpickle xpickle--instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d) => XmlPickler (a,b,c,d) where- xpickle = xp4Tuple xpickle xpickle xpickle xpickle--instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e) => XmlPickler (a,b,c,d,e) where- xpickle = xp5Tuple xpickle xpickle xpickle xpickle xpickle--instance XmlPickler a => XmlPickler [a] where- xpickle = xpList xpickle--instance XmlPickler a => XmlPickler (Maybe a) where- xpickle = xpOption xpickle---- ---------------------------------------------------------------- -------------------------------------------------------------{---- | 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--}--- -------------------------------------------------------------+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- ------------------------------------------------------------++{- |+ Module : Text.XML.HXT.Arrow.Pickle.Xml+ Copyright : Copyright (C) 2005-2021 Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : stable+ Portability: portable++ Pickler functions for converting between user defined data types+ and XmlTree data. Usefull for persistent storage and retreival+ of arbitray data as XML documents.++ This module is an adaptation of the pickler combinators+ developed by Andrew Kennedy+ ( https:\/\/www.microsoft.com\/en-us\/research\/wp-content\/uploads\/2004\/01\/picklercombinators.pdf )++ The difference to Kennedys approach is that the target is not+ a list of Chars but a list of XmlTrees. The basic picklers will+ convert data into XML text nodes. New are the picklers for+ creating elements and attributes.++ One extension was neccessary: The unpickling may fail.++ Old: Therefore the unpickler has a Maybe result type.+ Failure is used to unpickle optional elements+ (Maybe data) and lists of arbitray length.++ Since hxt-9.2.0: The unpicklers are implemented as+ a parser monad with an Either err val result type.+ This enables appropriate error messages , when unpickling+ XML stuff, that is not generated with the picklers and which contains+ some elements and/or attributes that are not handled when unpickling.++ There is an example program demonstrating the use+ of the picklers for a none trivial data structure.+ (see \"examples\/arrows\/pickle\" directory in the hxt distribution)++-}++-- ------------------------------------------------------------++module Text.XML.HXT.Arrow.Pickle.Xml+where++#if MIN_VERSION_base(4,8,0)+#else+import Control.Applicative (Applicative (..))+#endif++import Control.Arrow.ArrowList+import Control.Arrow.ListArrows+import Control.Monad ()++#if MIN_VERSION_mtl(2,2,0)+import Control.Monad.Except (MonadError (..))+#else+import Control.Monad.Error (MonadError (..))+#endif++import Control.Monad.State (MonadState (..), gets,+ modify)++import Data.Char (isDigit)+import Data.List (foldl')+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe (fromJust, fromMaybe)++import Text.XML.HXT.Arrow.Edit (xshowEscapeXml)+import Text.XML.HXT.Arrow.Pickle.Schema+import Text.XML.HXT.Arrow.ReadDocument (xread)+import Text.XML.HXT.Arrow.WriteDocument (writeDocumentToString)+import Text.XML.HXT.Arrow.XmlState+import Text.XML.HXT.DOM.Interface+import qualified Text.XML.HXT.DOM.ShowXml as XN+import qualified Text.XML.HXT.DOM.XmlNode as XN++{- just for embedded test cases, prefix with -- to activate+import Text.XML.HXT.Arrow.XmlArrow+import qualified Control.Arrow.ListArrows as X+-- -}++{- debug code+import qualified Debug.Trace as T+-- -}++-- ------------------------------------------------------------++data St = St { attributes :: [XmlTree]+ , contents :: [XmlTree]+ , nesting :: Int -- the remaining 3 fields are used only for unpickling+ , pname :: QName -- to generate appropriate error messages+ , pelem :: Bool+ } deriving (Show)++data PU a = PU { appPickle :: Pickler a -- (a, St) -> St+ , appUnPickle :: Unpickler a+ , theSchema :: Schema+ }++-- --------------------+--+-- The pickler++type Pickler a = a -> St -> St++-- --------------------+--+-- The unpickler monad, a combination of state and error monad++newtype Unpickler a = UP { runUP :: St -> (UnpickleVal a, St) }++type UnpickleVal a = Either UnpickleErr a++type UnpickleErr = (String, St)++instance Functor Unpickler where+ fmap f u = UP $ \ st ->+ let (r, st') = runUP u st in (fmap f r, st')++instance Applicative Unpickler where+ pure a = UP $ \ st -> (Right a, st)+ uf <*> ua = UP $ \ st ->+ let (f, st') = runUP uf st in+ case f of+ Left err -> (Left err, st')+ Right f' -> runUP (fmap f' ua) st'++instance Monad Unpickler where+ return = pure+ u >>= f = UP $ \ st ->+ let (r, st') = runUP u st in+ case r of+ Left err -> (Left err, st')+ Right v -> runUP (f v) st'++instance MonadState St Unpickler where+ get = UP $ \ st -> (Right st, st)+ put st = UP $ \ _ -> (Right (), st)++instance MonadError UnpickleErr Unpickler where+ throwError err+ = UP $ \ st -> (Left err, st)++ -- redundant, not (yet) used+ catchError u handler+ = UP $ \ st ->+ let (r, st') = runUP u st in+ case r of+ Left err -> runUP (handler err) st -- not st', state will be reset in error case+ _ -> (r, st')++throwMsg :: String -> Unpickler a+throwMsg msg = UP $ \ st -> (Left (msg, st), st)++-- | Choice combinator for unpickling+--+-- first 2 arguments are applied sequentially, but if the 1. one fails the+-- 3. arg is applied++mchoice :: Unpickler a -> (a -> Unpickler b) -> Unpickler b -> Unpickler b+mchoice u f v = UP $ \ st ->+ let (r, st') = runUP u st in+ case r of+ Right x+ -> runUP (f x) st' -- success+ Left e@(_msg, st'')+ -> if nesting st'' == nesting st -- true: failure in parsing curr contents+ then runUP v st -- try the alternative unpickler+ else (Left e, st') -- false: failure in unpickling a subtree of+ -- the current contents, so the whole unpickler+ -- must fail++-- | Lift a Maybe value into the Unpickler monad.+--+-- The 1. arg is the attached error message++liftMaybe :: String -> Maybe a -> Unpickler a+liftMaybe e v = case v of+ Nothing -> throwMsg e+ Just x -> return x++-- | Lift an Either value into the Unpickler monad++liftUnpickleVal :: UnpickleVal a -> Unpickler a+liftUnpickleVal v = UP $ \ st -> (v, st)++-- --------------------++getCont :: Unpickler XmlTree+getCont = do cs <- gets contents+ case cs of+ [] -> throwMsg "no more contents to be read"+ (x : xs) -> do modify (\ s -> s {contents = xs})+ return x++getAtt :: QName -> Unpickler XmlTree+getAtt qn = do as <- gets attributes+ case findAtt as of+ Nothing -> throwMsg $ "no attribute value found for " ++ show qn+ Just (a, as') -> do modify (\ s -> s {attributes = as'})+ return $ nonEmptyVal a+ where+ findAtt = findElem (maybe False (== qn) . XN.getAttrName)+ nonEmptyVal a'+ | null (XN.getChildren a') = XN.setChildren [et] a'+ | otherwise = a'+ where+ et = XN.mkText ""++getNSAtt :: String -> Unpickler ()+getNSAtt ns = do as <- gets attributes+ case findNS as of+ Nothing -> throwMsg $+ "no namespace declaration found for namespace " ++ show ns+ Just (_a, as') -> do modify (\ s -> s {attributes = as'})+ return ()+ where+ isNS t = (fromMaybe False . fmap isNameSpaceName . XN.getAttrName $ t)+ &&+ XN.xshow (XN.getChildren t) == ns+ findNS = findElem isNS++-- --------------------++emptySt :: St+emptySt = St { attributes = []+ , contents = []+ , nesting = 0+ , pname = mkName "/"+ , pelem = True+ }++putAtt :: QName -> [XmlTree] -> St -> St+putAtt qn v s = s {attributes = x : attributes s}+ where+ x = XN.mkAttr qn v+{-# INLINE putAtt #-}++putCont :: XmlTree -> St -> St+putCont x s = s {contents = x : contents s}+{-# INLINE putCont #-}++-- --------------------+--+-- generally useful function for splitting a value from a list++findElem :: (a -> Bool) -> [a] -> Maybe (a, [a])+findElem p = find' id+ where+ find' _ [] = Nothing+ find' prefix (x : xs)+ | p x = Just (x, prefix xs)+ | otherwise = find' (prefix . (x:)) xs++-- ------------------------------------------------------------+--+-- | Format the context of an error message.++formatSt :: St -> String+formatSt st = fcx +++ fa (attributes st) +++ fc (contents st)+ where+ fcx = "\n" ++ "context: " +++ ( if pelem st+ then "element"+ else "attribute"+ ) +++ " " ++ show (pname st)+ fc [] = ""+ fc cs = "\n" ++ "contents: " ++ formatXML cs+ fa [] = ""+ fa as = "\n" ++ "attributes: " ++ formatXML as+ formatXML = format 80 . showXML+ showXML = concat . runLA ( xshowEscapeXml unlistA )+ format n s = let s' = take (n + 1) s in+ if length s' <= n then s' else take n s ++ "..."++-- ------------------------------------------------------------++-- | conversion of an arbitrary value into an XML document tree.+--+-- The pickler, first parameter, controls the conversion process.+-- Result is a complete document tree including a root node++pickleDoc :: PU a -> a -> XmlTree+pickleDoc p v = XN.mkRoot (attributes st) (contents st)+ where+ st = appPickle p v emptySt++-- | Conversion of an XML document tree into an arbitrary data type+--+-- The inverse of 'pickleDoc'.+-- This law should hold for all picklers: @ unpickle px . pickle px $ v == Just v @.+-- Not every possible combination of picklers does make sense.+-- For reconverting a value from an XML tree, is becomes neccessary,+-- to introduce \"enough\" markup for unpickling the value++unpickleDoc :: PU a -> XmlTree -> Maybe a+unpickleDoc p = either (const Nothing) Just+ . unpickleDoc' p++-- | Like unpickleDoc but with a (sometimes) useful error message, when unpickling failed.++unpickleDoc' :: PU a -> XmlTree -> Either String a+unpickleDoc' p t+ | XN.isRoot t = mapErr $+ unpickleElem' p 0 t+ | otherwise = unpickleDoc' p (XN.mkRoot [] [t])+ where+ mapErr = either ( Left .+ \ (msg, st) -> msg ++ formatSt st+ ) Right++-- | The main entry for unpickling, called by unpickleDoc++unpickleElem' :: PU a -> Int -> XmlTree -> UnpickleVal a+unpickleElem' p l t+ = -- T.trace ("unpickleElem': " ++ show t) $+ ( fst . runUP (appUnPickle p) )+ $ St { attributes = fromMaybe [] .+ XN.getAttrl $ t+ , contents = XN.getChildren t+ , nesting = l+ , pname = fromJust .+ XN.getName $ t+ , pelem = XN.isElem t+ }++-- ------------------------------------------------------------++-- | Pickles a value, then writes the document to a string.++showPickled :: (XmlPickler a) => SysConfigList -> a -> String+showPickled a = concat . (pickleDoc xpickle >>> runLA (writeDocumentToString a))++-- ------------------------------------------------------------++-- | The zero pickler+--+-- Encodes nothing, fails always during unpickling++xpZero :: String -> PU a+xpZero err = PU { appPickle = const id+ , appUnPickle = throwMsg err+ , theSchema = scNull+ }++-- | unit pickler++xpUnit :: PU ()+xpUnit = xpLift ()++-- | Check EOF pickler.+--+-- When pickling, this behaves like the unit pickler.+-- The unpickler fails, when there is some unprocessed XML contents left.++xpCheckEmptyContents :: PU a -> PU a+xpCheckEmptyContents pa = PU { appPickle = appPickle pa+ , appUnPickle = do res <- appUnPickle pa+ cs <- gets contents+ if null cs+ then return res+ else contentsLeft+ , theSchema = scNull+ }+ where+ contentsLeft = throwMsg+ "xpCheckEmptyContents: unprocessed XML content detected"++-- | Like xpCheckEmptyContents, but checks the attribute list++xpCheckEmptyAttributes :: PU a -> PU a+xpCheckEmptyAttributes pa+ = PU { appPickle = appPickle pa+ , appUnPickle = do res <- appUnPickle pa+ as <- gets attributes+ if null as+ then return res+ else attributesLeft+ , theSchema = scNull+ }+ where+ attributesLeft = throwMsg+ "xpCheckEmptyAttributes: unprocessed XML attribute(s) detected"++-- | Composition of xpCheckEmptyContents and xpCheckAttributes++xpCheckEmpty :: PU a -> PU a+xpCheckEmpty = xpCheckEmptyAttributes . xpCheckEmptyContents++xpLift :: a -> PU a+xpLift x = PU { appPickle = const id+ , appUnPickle = return x+ , theSchema = scEmpty+ }++-- | Lift a Maybe value to a pickler.+--+-- @Nothing@ is mapped to the zero pickler, @Just x@ is pickled with @xpLift x@.++xpLiftMaybe :: Maybe a -> PU a+xpLiftMaybe v = (xpLiftMaybe'' v) { theSchema = scOption scEmpty }+ where+ xpLiftMaybe'' Nothing = xpZero "xpLiftMaybe: got Nothing"+ xpLiftMaybe'' (Just x) = xpLift x++xpLiftEither :: Either String a -> PU a+xpLiftEither v = (xpLiftEither'' v) { theSchema = scOption scEmpty }+ where+ xpLiftEither'' (Left err) = xpZero err+ xpLiftEither'' (Right x) = xpLift x++-- | Combine two picklers sequentially.+--+-- If the first fails during+-- unpickling, the whole unpickler fails++xpSeq :: (b -> a) -> PU a -> (a -> PU b) -> PU b+xpSeq f pa k+ = PU { appPickle = ( \ b ->+ let a = f b in+ appPickle pa a . appPickle (k a) b+ )+ , appUnPickle = appUnPickle pa >>= (appUnPickle . k)+ , theSchema = undefined+ }++-- | First apply a fixed pickler/unpickler, then a 2. one+--+-- If the first fails during unpickling, the whole pickler fails.+-- This can be used to check some properties of the input, e.g. whether+-- a given fixed attribute or a namespace declaration exists+-- ('xpAddFixedAttr', 'xpAddNSDecl')+-- or to filter the input, e.g. to ignore some elements or attributes+-- ('xpFilterCont', 'xpFilterAttr').+--+-- When pickling, this can be used to insert some fixed XML pieces,+-- e.g. namespace declarations,+-- class attributes or other stuff.++xpSeq' :: PU () -> PU a -> PU a+xpSeq' pa = xpWrap ( snd+ , \ y -> ((), y)+ ) .+ xpPair pa++-- | combine two picklers with a choice+--+-- Run two picklers in sequence like with xpSeq.+-- If during unpickling the first one fails,+-- an alternative pickler (first argument) is applied.+-- This pickler is only used as combinator for unpickling.++xpChoice :: PU b -> PU a -> (a -> PU b) -> Unpickler b+xpChoice pb pa k = mchoice (appUnPickle pa) (appUnPickle . k) (appUnPickle pb)+++-- | map value into another domain and apply pickler there+--+-- One of the most often used picklers.++xpWrap :: (a -> b, b -> a) -> PU a -> PU b+xpWrap (i, j) pa = (xpSeq j pa (xpLift . i)) { theSchema = theSchema pa }++-- | like 'xpWrap', but if the inverse mapping is undefined, the unpickler fails+--+-- Map a value into another domain. If the inverse mapping is+-- undefined (Nothing), the unpickler fails+--+-- Deprecated: Use xpWrapEither, this gives better error messages++xpWrapMaybe :: (a -> Maybe b, b -> a) -> PU a -> PU b+xpWrapMaybe (i, j) pa = (xpSeq j pa (xpLiftMaybe . i)) { theSchema = theSchema pa }++-- | like 'xpWrap', but if the inverse mapping is undefined, the unpickler fails+--+-- Map a value into another domain. If the inverse mapping is+-- undefined, the unpickler fails with an error message in the Left component++xpWrapEither :: (a -> Either String b, b -> a) -> PU a -> PU b+xpWrapEither (i, j) pa = (xpSeq j pa (xpLiftEither . i)) { theSchema = theSchema pa }++-- ------------------------------------------------------------++-- | pickle a pair of values sequentially+--+-- Used for pairs or together with wrap for pickling+-- algebraic data types with two components++xpPair :: PU a -> PU b -> PU (a, b)+xpPair pa pb+ = ( xpSeq fst pa (\ a ->+ xpSeq snd pb (\ b ->+ xpLift (a,b)))+ ) { theSchema = scSeq (theSchema pa) (theSchema pb) }++-- | Like 'xpPair' but for triples++xpTriple :: PU a -> PU b -> PU c -> PU (a, b, c)+xpTriple pa pb pc+ = xpWrap (toTriple, fromTriple) (xpPair pa (xpPair pb pc))+ where+ toTriple ~(a, ~(b, c)) = (a, b, c )+ fromTriple ~(a, b, c ) = (a, (b, c))++-- | Like 'xpPair' and 'xpTriple' but for 4-tuples++xp4Tuple :: PU a -> PU b -> PU c -> PU d -> PU (a, b, c, d)+xp4Tuple pa pb pc pd+ = xpWrap (toQuad, fromQuad) (xpPair pa (xpPair pb (xpPair pc pd)))+ where+ toQuad ~(a, ~(b, ~(c, d))) = (a, b, c, d )+ fromQuad ~(a, b, c, d ) = (a, (b, (c, d)))++-- | Like 'xpPair' and 'xpTriple' but for 5-tuples++xp5Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> PU (a, b, c, d, e)+xp5Tuple pa pb pc pd pe+ = xpWrap (toQuint, fromQuint) (xpPair pa (xpPair pb (xpPair pc (xpPair pd pe))))+ where+ toQuint ~(a, ~(b, ~(c, ~(d, e)))) = (a, b, c, d, e )+ fromQuint ~(a, b, c, d, e ) = (a, (b, (c, (d, e))))++-- | Like 'xpPair' and 'xpTriple' but for 6-tuples++xp6Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> PU f -> PU (a, b, c, d, e, f)+xp6Tuple pa pb pc pd pe pf+ = xpWrap (toSix, fromSix) (xpPair pa (xpPair pb (xpPair pc (xpPair pd (xpPair pe pf)))))+ where+ toSix ~(a, ~(b, ~(c, ~(d, ~(e, f))))) = (a, b, c, d, e, f )+ fromSix ~(a, b, c, d, e, f) = (a, (b, (c, (d, (e, f)))))++-- ------------------------------------------------------------++-- | Like 'xpPair' and 'xpTriple' but for 7-tuples+--+-- Thanks to Tony Morris for doing xp7Tuple, ..., xp24Tuple.++xp7Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+ PU f -> PU g -> PU (a, b, c, d, e, f, g)+xp7Tuple a b c d e f g+ = xpWrap ( \ (a, (b, c, d, e, f, g)) -> (a, b, c, d, e, f, g)+ , \ (a, b, c, d, e, f, g) -> (a, (b, c, d, e, f, g))+ )+ (xpPair a (xp6Tuple b c d e f g))++xp8Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+ PU f -> PU g -> PU h -> PU (a, b, c, d, e, f, g, h)+xp8Tuple a b c d e f g h+ = xpWrap ( \ ((a, b), (c, d, e, f, g, h)) -> (a, b, c, d, e, f, g, h)+ , \ (a, b, c, d, e, f, g, h) -> ((a, b), (c, d, e, f, g, h))+ )+ (xpPair (xpPair a b) (xp6Tuple c d e f g h))++xp9Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+ PU f -> PU g -> PU h -> PU i -> PU (a, b, c, d, e, f, g, h, i)+xp9Tuple a b c d e f g h i+ = xpWrap ( \ ((a, b, c), (d, e, f, g, h, i)) -> (a, b, c, d, e, f, g, h, i)+ , \ (a, b, c, d, e, f, g, h, i) -> ((a, b, c), (d, e, f, g, h, i))+ )+ (xpPair (xpTriple a b c) (xp6Tuple d e f g h i))++xp10Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+ PU f -> PU g -> PU h -> PU i -> PU j ->+ PU (a, b, c, d, e, f, g, h, i, j)+xp10Tuple a b c d e f g h i j+ = xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j)) -> (a, b, c, d, e, f, g, h, i, j)+ , \ (a, b, c, d, e, f, g, h, i, j) -> ((a, b, c, d), (e, f, g, h, i, j))+ )+ (xpPair (xp4Tuple a b c d) (xp6Tuple e f g h i j))++xp11Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+ PU f -> PU g -> PU h -> PU i -> PU j ->+ PU k -> PU (a, b, c, d, e, f, g, h, i, j, k)+xp11Tuple a b c d e f g h i j k+ = xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k)) -> (a, b, c, d, e, f, g, h, i, j, k)+ , \ (a, b, c, d, e, f, g, h, i, j, k) -> ((a, b, c, d, e), (f, g, h, i, j, k))+ )+ (xpPair (xp5Tuple a b c d e) (xp6Tuple f g h i j k))++xp12Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+ PU f -> PU g -> PU h -> PU i -> PU j ->+ PU k -> PU l -> PU (a, b, c, d, e, f, g, h, i, j, k, l)+xp12Tuple a b c d e f g h i j k l+ = xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l)) -> (a, b, c, d, e, f, g, h, i, j, k, l)+ , \ (a, b, c, d, e, f, g, h, i, j, k, l) -> ((a, b, c, d, e, f), (g, h, i, j, k, l))+ )+ (xpPair (xp6Tuple a b c d e f) (xp6Tuple g h i j k l))++xp13Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+ PU f -> PU g -> PU h -> PU i -> PU j ->+ PU k -> PU l -> PU m -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m)+xp13Tuple a b c d e f g h i j k l m+ = xpWrap ( \ (a, (b, c, d, e, f, g), (h, i, j, k, l, m)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m)+ , \ (a, b, c, d, e, f, g, h, i, j, k, l, m) -> (a, (b, c, d, e, f, g), (h, i, j, k, l, m))+ )+ (xpTriple a (xp6Tuple b c d e f g) (xp6Tuple h i j k l m))++xp14Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+ PU f -> PU g -> PU h -> PU i -> PU j ->+ PU k -> PU l -> PU m -> PU n -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+xp14Tuple a b c d e f g h i j k l m n+ = xpWrap ( \ ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+ , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -> ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n))+ )+ (xpTriple (xpPair a b) (xp6Tuple c d e f g h) (xp6Tuple i j k l m n))++xp15Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+ PU f -> PU g -> PU h -> PU i -> PU j ->+ PU k -> PU l -> PU m -> PU n -> PU o ->+ PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+xp15Tuple a b c d e f g h i j k l m n o+ = xpWrap ( \ ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+ , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -> ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o))+ )+ (xpTriple (xpTriple a b c) (xp6Tuple d e f g h i) (xp6Tuple j k l m n o))++xp16Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+ PU f -> PU g -> PU h -> PU i -> PU j ->+ PU k -> PU l -> PU m -> PU n -> PU o ->+ PU p -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)+xp16Tuple a b c d e f g h i j k l m n o p+ = xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)+ , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) -> ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p))+ )+ (xpTriple (xp4Tuple a b c d) (xp6Tuple e f g h i j) (xp6Tuple k l m n o p))++xp17Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+ PU f -> PU g -> PU h -> PU i -> PU j ->+ PU k -> PU l -> PU m -> PU n -> PU o ->+ PU p -> PU q -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q)+xp17Tuple a b c d e f g h i j k l m n o p q+ = xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q)+ , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) -> ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q))+ )+ (xpTriple (xp5Tuple a b c d e) (xp6Tuple f g h i j k) (xp6Tuple l m n o p q))++xp18Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+ PU f -> PU g -> PU h -> PU i -> PU j ->+ PU k -> PU l -> PU m -> PU n -> PU o ->+ PU p -> PU q -> PU r -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r)+xp18Tuple a b c d e f g h i j k l m n o p q r+ = xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r)+ , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) -> ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r))+ )+ (xpTriple (xp6Tuple a b c d e f) (xp6Tuple g h i j k l) (xp6Tuple m n o p q r))++xp19Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+ PU f -> PU g -> PU h -> PU i -> PU j ->+ PU k -> PU l -> PU m -> PU n -> PU o ->+ PU p -> PU q -> PU r -> PU s -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s)+xp19Tuple a b c d e f g h i j k l m n o p q r s+ = xpWrap ( \ (a, (b, c, d, e, f, g), (h, i, j, k, l, m), (n, o, p, q, r, s)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s)+ , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) -> (a, (b, c, d, e, f, g), (h, i, j, k, l, m), (n, o, p, q, r, s))+ )+ (xp4Tuple a (xp6Tuple b c d e f g) (xp6Tuple h i j k l m) (xp6Tuple n o p q r s))++xp20Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+ PU f -> PU g -> PU h -> PU i -> PU j ->+ PU k -> PU l -> PU m -> PU n -> PU o ->+ PU p -> PU q -> PU r -> PU s -> PU t ->+ PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t)+xp20Tuple a b c d e f g h i j k l m n o p q r s t+ = xpWrap ( \ ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n), (o, p, q, r, s, t)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t)+ , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) -> ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n), (o, p, q, r, s, t))+ )+ (xp4Tuple (xpPair a b) (xp6Tuple c d e f g h) (xp6Tuple i j k l m n) (xp6Tuple o p q r s t))++xp21Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+ PU f -> PU g -> PU h -> PU i -> PU j ->+ PU k -> PU l -> PU m -> PU n -> PU o ->+ PU p -> PU q -> PU r -> PU s -> PU t ->+ PU u -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u)+xp21Tuple a b c d e f g h i j k l m n o p q r s t u+ = xpWrap ( \ ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o), (p, q, r, s, t, u)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u)+ , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) -> ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o), (p, q, r, s, t, u))+ )+ (xp4Tuple (xpTriple a b c) (xp6Tuple d e f g h i) (xp6Tuple j k l m n o) (xp6Tuple p q r s t u))++xp22Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+ PU f -> PU g -> PU h -> PU i -> PU j ->+ PU k -> PU l -> PU m -> PU n -> PU o ->+ PU p -> PU q -> PU r -> PU s -> PU t ->+ PU u -> PU v -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v)+xp22Tuple a b c d e f g h i j k l m n o p q r s t u v+ = xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p), (q, r, s, t, u, v)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v)+ , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) -> ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p), (q, r, s, t, u, v))+ )+ (xp4Tuple (xp4Tuple a b c d) (xp6Tuple e f g h i j) (xp6Tuple k l m n o p) (xp6Tuple q r s t u v))++xp23Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+ PU f -> PU g -> PU h -> PU i -> PU j ->+ PU k -> PU l -> PU m -> PU n -> PU o ->+ PU p -> PU q -> PU r -> PU s -> PU t ->+ PU u -> PU v -> PU w -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w)+xp23Tuple a b c d e f g h i j k l m n o p q r s t u v w+ = xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q), (r, s, t, u, v, w)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w)+ , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) -> ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q), (r, s, t, u, v, w))+ )+ (xp4Tuple (xp5Tuple a b c d e) (xp6Tuple f g h i j k) (xp6Tuple l m n o p q) (xp6Tuple r s t u v w))++-- | Hopefully no one needs a xp25Tuple++xp24Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->+ PU f -> PU g -> PU h -> PU i -> PU j ->+ PU k -> PU l -> PU m -> PU n -> PU o ->+ PU p -> PU q -> PU r -> PU s -> PU t ->+ PU u -> PU v -> PU w -> PU x -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x)+xp24Tuple a b c d e f g h i j k l m n o p q r s t u v w x+ = xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r), (s, t, u, v, w, x)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x)+ , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) -> ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r), (s, t, u, v, w, x))+ )+ (xp4Tuple (xp6Tuple a b c d e f) (xp6Tuple g h i j k l) (xp6Tuple m n o p q r) (xp6Tuple s t u v w x))++-- ------------------------------------------------------------+++-- | Pickle a string into an XML text node+--+-- One of the most often used primitive picklers. Attention:+-- For pickling empty strings use 'xpText0'. If the text has a more+-- specific datatype than xsd:string, use 'xpTextDT'++xpText :: PU String+xpText = xpTextDT scString1+{-# INLINE xpText #-}++-- | Pickle a string into an XML text node+--+-- Text pickler with a description of the structure of the text+-- by a schema. A schema for a data type can be defined by 'Text.XML.HXT.Arrow.Pickle.Schema.scDT'.+-- In 'Text.XML.HXT.Arrow.Pickle.Schema' there are some more functions for creating+-- simple datatype descriptions.++xpTextDT :: Schema -> PU String+xpTextDT sc = PU { appPickle = putCont . XN.mkText+ , appUnPickle = do t <- getCont+ liftMaybe "xpText: XML text expected" $ XN.getText t+ , theSchema = sc+ }++-- | Pickle a possibly empty string into an XML node.+--+-- Must be used in all places, where empty strings are legal values.+-- If the content of an element can be an empty string, this string disapears+-- during storing the DOM into a document and reparse the document.+-- So the empty text node becomes nothing, and the pickler must deliver an empty string,+-- if there is no text node in the document.++xpText0 :: PU String+xpText0 = xpText0DT scString1+{-# INLINE xpText0 #-}++-- | Pickle a possibly empty string with a datatype description into an XML node.+--+-- Like 'xpText0' but with extra Parameter for datatype description as in 'xpTextDT'.++xpText0DT :: Schema -> PU String+xpText0DT sc = xpWrap (fromMaybe "", emptyToNothing) $+ xpOption $+ xpTextDT sc+ where+ emptyToNothing "" = Nothing+ emptyToNothing x = Just x++-- | Pickle an arbitrary value by applyling show during pickling+-- and read during unpickling.+--+-- Real pickling is then done with 'xpText'.+-- One of the most often used pimitive picklers. Applicable for all+-- types which are instances of @Read@ and @Show@++xpPrim :: (Read a, Show a) => PU a+xpPrim = xpWrapEither (readMaybe, show) xpText+ where+ readMaybe :: Read a => String -> Either String a+ readMaybe str = val (reads str)+ where+ val [(x,"")] = Right x+ val _ = Left $ "xpPrim: reading string " ++ show str ++ " failed"++-- | Pickle an Int+xpInt :: PU Int+xpInt = xpWrapEither (readMaybe, show) xpText+ where+ readMaybe xs@(_:_)+ | all isDigit xs = Right . foldl' (\ r c -> 10 * r + (fromEnum c - fromEnum '0')) 0 $ xs+ readMaybe ('-' : xs) = fmap (0 -) . readMaybe $ xs+ readMaybe ('+' : xs) = readMaybe $ xs+ readMaybe xs = Left $ "xpInt: reading an Int from string " ++ show xs ++ " failed"++-- ------------------------------------------------------------++-- | Pickle an XmlTree by just adding it+--+-- Usefull for components of type XmlTree in other data structures++xpTree :: PU XmlTree+xpTree = PU { appPickle = putCont+ , appUnPickle = getCont+ , theSchema = Any+ }++-- | Pickle a whole list of XmlTrees by just adding the list, unpickle is done by taking all element contents.+--+-- This pickler should always be combined with 'xpElem' for taking the whole contents of an element.++xpTrees :: PU [XmlTree]+xpTrees = (xpList xpTree) { theSchema = Any }++-- | Pickle a string representing XML contents by inserting the tree representation into the XML document.+--+-- Unpickling is done by converting the contents with+-- 'Text.XML.HXT.Arrow.Edit.xshowEscapeXml' into a string,+-- this function will escape all XML special chars, such that pickling the value back becomes save.+-- Pickling is done with 'Text.XML.HXT.Arrow.ReadDocument.xread'++xpXmlText :: PU String+xpXmlText = xpWrap ( showXML, readXML ) $ xpTrees+ where+ showXML = concat . runLA ( xshowEscapeXml unlistA )+ readXML = runLA xread++-- ------------------------------------------------------------++-- | Encoding of optional data by ignoring the Nothing case during pickling+-- and relying on failure during unpickling to recompute the Nothing case+--+-- The default pickler for Maybe types++xpOption :: PU a -> PU (Maybe a)+xpOption pa = PU { appPickle = ( \ a ->+ case a of+ Nothing -> id+ Just x -> appPickle pa x+ )++ , appUnPickle = xpChoice (xpLift Nothing) pa (xpLift . Just)++ , theSchema = scOption (theSchema pa)+ }++-- | Optional conversion with default value+--+-- The default value is not encoded in the XML document,+-- during unpickling the default value is inserted if the pickler fails++xpDefault :: (Eq a) => a -> PU a -> PU a+xpDefault df = xpWrap ( fromMaybe df+ , \ x -> if x == df then Nothing else Just x+ ) .+ xpOption++-- ------------------------------------------------------------++-- | Encoding of list values by pickling all list elements sequentially.+--+-- Unpickler relies on failure for detecting the end of the list.+-- The standard pickler for lists. Can also be used in combination with 'xpWrap'+-- for constructing set and map picklers++xpList :: PU a -> PU [a]+xpList pa = PU { appPickle = ( \ a ->+ case a of+ [] -> id+ _:_ -> appPickle pc a+ )+ , appUnPickle = xpChoice+ (xpLift [])+ pa+ (\ x -> xpSeq id (xpList pa) (\xs -> xpLift (x:xs)))++ , theSchema = scList (theSchema pa)+ }+ where+ pc = xpSeq head pa (\ x ->+ xpSeq tail (xpList pa) (\ xs ->+ xpLift (x:xs) ))++-- | Encoding of a none empty list of values+--+-- Attention: when calling this pickler with an empty list,+-- an internal error \"head of empty list is raised\".++xpList1 :: PU a -> PU [a]+xpList1 pa = ( xpWrap (\ (x, xs) -> x : xs+ ,\ x -> (head x, tail x)+ ) $+ xpPair pa (xpList pa)+ ) { theSchema = scList1 (theSchema pa) }++-- ------------------------------------------------------------++-- | Standard pickler for maps+--+-- This pickler converts a map into a list of pairs.+-- All key value pairs are mapped to an element with name (1.arg),+-- the key is encoded as an attribute named by the 2. argument,+-- the 3. arg is the pickler for the keys, the last one for the values++xpMap :: Ord k => String -> String -> PU k -> PU v -> PU (Map k v)+xpMap en an xpk xpv+ = xpWrap ( M.fromList+ , M.toList+ ) $+ xpList $+ xpElem en $+ xpPair ( xpAttr an $ xpk ) xpv++-- ------------------------------------------------------------++-- | Pickler for sum data types.+--+-- Every constructor is mapped to an index into the list of picklers.+-- The index is used only during pickling, not during unpickling, there the 1. match is taken++xpAlt :: (a -> Int) -> [PU a] -> PU a+xpAlt tag ps = PU { appPickle = \ a ->+ appPickle (ps !! tag a) a++ , appUnPickle = case ps of+ [] -> throwMsg "xpAlt: no matching unpickler found for a sum datatype"+ pa:ps1 -> xpChoice (xpAlt tag ps1) pa xpLift++ , theSchema = scAlts (map theSchema ps)+ }++-- ------------------------------------------------------------++-- | Pickler for wrapping\/unwrapping data into an XML element+--+-- Extra parameter is the element name given as a QName. THE pickler for constructing+-- nested structures+--+-- Example:+--+-- > xpElemQN (mkName "number") $ xpickle+--+-- will map an (42::Int) onto+--+-- > <number>42</number>++xpElemQN :: QName -> PU a -> PU a+xpElemQN qn pa = PU { appPickle = ( \ a ->+ let st' = appPickle pa a emptySt in+ putCont (XN.mkElement qn (attributes st') (contents st'))+ )+ , appUnPickle = upElem+ , theSchema = scElem (qualifiedName qn) (theSchema pa)+ }+ where+ upElem = do t <- getCont+ n <- liftMaybe "xpElem: XML element expected" $ XN.getElemName t+ if n /= qn+ then throwMsg ("xpElem: got element name " ++ show n ++ ", but expected " ++ show qn)+ else do l <- gets nesting+ liftUnpickleVal $ unpickleElem' (xpCheckEmpty pa) (l + 1) t++-- | convenient Pickler for xpElemQN+--+-- > xpElem n = xpElemQN (mkName n)++xpElem :: String -> PU a -> PU a+xpElem = xpElemQN . mkName++-- | convenient Pickler for xpElemQN+-- for pickling elements with respect to namespaces+--+-- > xpElemNS ns px lp = xpElemQN (mkQName px lp ns)++xpElemNS :: String -> String -> String -> PU a -> PU a+xpElemNS ns px lp+ = xpElemQN $ mkQName px lp ns++-- ------------------------------------------------------------++-- | Pickler for wrapping\/unwrapping data into an XML element with an attribute with given value+--+-- To make XML structures flexible but limit the number of different elements, it's sometimes+-- useful to use a kind of generic element with a key value structure+--+-- Example:+--+-- > <attr name="key1">value1</attr>+-- > <attr name="key2">value2</attr>+-- > <attr name="key3">value3</attr>+--+-- the Haskell datatype may look like this+--+-- > type T = T { key1 :: Int ; key2 :: String ; key3 :: Double }+--+-- Then the picker for that type looks like this+--+-- > xpT :: PU T+-- > xpT = xpWrap ( uncurry3 T, \ t -> (key1 t, key2 t, key3 t) ) $+-- > xpTriple (xpElemWithAttrValue "attr" "name" "key1" $ xpickle)+-- > (xpElemWithAttrValue "attr" "name" "key2" $ xpText0)+-- > (xpElemWithAttrValue "attr" "name" "key3" $ xpickle)++xpElemWithAttrValue :: String -> String -> String -> PU a -> PU a+xpElemWithAttrValue name an av pa+ = xpElem name $+ xpAddFixedAttr an av $+ pa++-- ------------------------------------------------------------++-- | Pickler for storing\/retreiving data into\/from an attribute value+--+-- The attribute is inserted in the surrounding element constructed by the 'xpElem' pickler++xpAttrQN :: QName -> PU a -> PU a+xpAttrQN qn pa = PU { appPickle = ( \ a ->+ let st' = appPickle pa a emptySt in+ putAtt qn (contents st')+ )+ , appUnPickle = upAttr+ , theSchema = scAttr (qualifiedName qn) (theSchema pa)+ }+ where+ upAttr = do a <- getAtt qn+ l <- gets nesting+ liftUnpickleVal $ unpickleElem' (xpCheckEmptyContents pa) l a++-- | convenient Pickler for xpAttrQN+--+-- > xpAttr n = xpAttrQN (mkName n)++xpAttr :: String -> PU a -> PU a+xpAttr = xpAttrQN . mkName++-- | convenient Pickler for xpAttrQN+--+-- > xpAttr ns px lp = xpAttrQN (mkQName px lp ns)++xpAttrNS :: String -> String -> String -> PU a -> PU a+xpAttrNS ns px lp+ = xpAttrQN (mkQName px lp ns)++-- | A text attribute.+xpTextAttr :: String -> PU String+xpTextAttr = flip xpAttr xpText++-- | Add an optional attribute for an optional value (Maybe a).++xpAttrImplied :: String -> PU a -> PU (Maybe a)+xpAttrImplied name pa+ = xpOption $ xpAttr name pa++xpAttrFixed :: String -> String -> PU ()+xpAttrFixed name val+ = ( xpWrapEither ( \ v ->+ if v == val+ then Right ()+ else Left ( "xpAttrFixed: value "+ ++ show val+ ++ " expected, but got "+ ++ show v+ )+ , const val+ ) $+ xpAttr name xpText+ ) { theSchema = scAttr name (scFixed val) }++-- | Add/Check an attribute with a fixed value.+--++xpAddFixedAttr :: String -> String -> PU a -> PU a+xpAddFixedAttr name val+ = xpSeq' $ xpAttrFixed name val++-- | Add a namespace declaration.+--+-- When generating XML the namespace decl is added,+-- when reading a document, the unpickler checks+-- whether there is a namespace declaration for the given+-- namespace URI (2. arg)++xpAddNSDecl :: String -> String -> PU a -> PU a+xpAddNSDecl name val+ = xpSeq' $ xpAttrNSDecl name' val+ where+ name'+ | null name = "xmlns"+ | otherwise = "xmlns:" ++ name++xpAttrNSDecl :: String -> String -> PU ()+xpAttrNSDecl name ns+ = PU { appPickle = const $ putAtt (mkName name) [XN.mkText ns]+ , appUnPickle = getNSAtt ns+ , theSchema = scAttr name (scFixed ns)+ }++-- ------------------------------------------------------------++xpIgnoreCont :: LA XmlTree XmlTree -> PU ()+xpIgnoreCont = xpIgnoreInput $ \ mf s -> s {contents = mf $ contents s}++xpIgnoreAttr :: LA XmlTree XmlTree -> PU ()+xpIgnoreAttr = xpIgnoreInput $ \ mf s -> s {attributes = mf $ attributes s}++-- | When unpickling, filter the contents of the element currently processed,+-- before applying the pickler argument+--+-- Maybe useful to ignore some stuff in the input, or to do some cleanup before unpickling.++xpFilterCont :: LA XmlTree XmlTree -> PU a -> PU a+xpFilterCont f = xpSeq' $ xpIgnoreCont f++-- | Same as 'xpFilterCont' but for the attribute list of the element currently processed.+--+-- Maybe useful to ignore some stuff in the input, e.g. class attributes, or to do some cleanup before unpickling.++xpFilterAttr :: LA XmlTree XmlTree -> PU a -> PU a+xpFilterAttr f = xpSeq' $ xpIgnoreAttr f++xpIgnoreInput :: (([XmlTree] -> [XmlTree]) -> St -> St) -> LA XmlTree XmlTree -> PU ()+xpIgnoreInput m f+ = PU { appPickle = const id+ , appUnPickle = do modify (m filterCont)+ return ()+ , theSchema = scNull+ }+ where+ filterCont = runLA (unlistA >>> f)++-- ------------------------------------------------------------++-- | The class for overloading 'xpickle', the default pickler++class XmlPickler a where+ xpickle :: PU a++instance XmlPickler Int where+ xpickle = xpPrim++instance XmlPickler Integer where+ xpickle = xpPrim++{-+ no instance of XmlPickler Char+ because then every text would be encoded+ char by char, because of the instance for lists++instance XmlPickler Char where+ xpickle = xpPrim+-}++instance XmlPickler () where+ xpickle = xpUnit++instance (XmlPickler a, XmlPickler b) => XmlPickler (a,b) where+ xpickle = xpPair xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c) => XmlPickler (a,b,c) where+ xpickle = xpTriple xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d) => XmlPickler (a,b,c,d) where+ xpickle = xp4Tuple xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e) => XmlPickler (a,b,c,d,e) where+ xpickle = xp5Tuple xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f) => XmlPickler (a, b, c, d, e, f) where+ xpickle = xp6Tuple xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g) => XmlPickler (a, b, c, d, e, f, g) where+ xpickle = xp7Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h) => XmlPickler (a, b, c, d, e, f, g, h) where+ xpickle = xp8Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i) => XmlPickler (a, b, c, d, e, f, g, h, i) where+ xpickle = xp9Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j) => XmlPickler (a, b, c, d, e, f, g, h, i, j) where+ xpickle = xp10Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k) where+ xpickle = xp11Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l) where+ xpickle = xp12Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m) where+ xpickle = xp13Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where+ xpickle = xp14Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n, XmlPickler o) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where+ xpickle = xp15Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n, XmlPickler o, XmlPickler p) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where+ xpickle = xp16Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n, XmlPickler o, XmlPickler p, XmlPickler q) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) where+ xpickle = xp17Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n, XmlPickler o, XmlPickler p, XmlPickler q, XmlPickler r) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) where+ xpickle = xp18Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n, XmlPickler o, XmlPickler p, XmlPickler q, XmlPickler r, XmlPickler s) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) where+ xpickle = xp19Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n, XmlPickler o, XmlPickler p, XmlPickler q, XmlPickler r, XmlPickler s, XmlPickler t) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) where+ xpickle = xp20Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n, XmlPickler o, XmlPickler p, XmlPickler q, XmlPickler r, XmlPickler s, XmlPickler t, XmlPickler u) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) where+ xpickle = xp21Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n, XmlPickler o, XmlPickler p, XmlPickler q, XmlPickler r, XmlPickler s, XmlPickler t, XmlPickler u, XmlPickler v) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) where+ xpickle = xp22Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n, XmlPickler o, XmlPickler p, XmlPickler q, XmlPickler r, XmlPickler s, XmlPickler t, XmlPickler u, XmlPickler v, XmlPickler w) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) where+ xpickle = xp23Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e, XmlPickler f, XmlPickler g, XmlPickler h, XmlPickler i, XmlPickler j, XmlPickler k, XmlPickler l, XmlPickler m, XmlPickler n, XmlPickler o, XmlPickler p, XmlPickler q, XmlPickler r, XmlPickler s, XmlPickler t, XmlPickler u, XmlPickler v, XmlPickler w, XmlPickler x) => XmlPickler (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) where+ xpickle = xp24Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle xpickle++instance XmlPickler a => XmlPickler [a] where+ xpickle = xpList xpickle++instance XmlPickler a => XmlPickler (Maybe a) where+ xpickle = xpOption xpickle++-- | Pickler for an arbitrary datum of type 'Either'.+instance (XmlPickler l, XmlPickler r) => XmlPickler (Either l r) where+ xpickle = pick xpickle xpickle+ where+ pick :: PU l -> PU r -> PU (Either l r)+ pick lPickler rPickler =+ xpAlt (const 0 `either` const 1)+ [ xpWrap ( Left -- Construct.+ , \ (Left l ) -> l -- Deconstruct.+ ) lPickler+ , xpWrap ( Right -- Construct.+ , \ (Right r) -> r -- Deconstruct.+ ) rPickler+ ]++-- ------------------------------------------------------------++{-+-- Thanks to treeowl:++-- This script was used to generate the tuple instances:++import Data.List (intercalate)++-- | Generates XmlPickler instances for tuples of size 4 <= n <= 24+mkInstance :: Int -> String+mkInstance n =+ "instance (" ++ constrainsts ++ ") => XmlPickler (" ++ tuple ++ ") where\n" +++ " xpickle = xp" ++ show n ++ "Tuple " ++ xpickleStrings+ where+ xpickleStrings = intercalate " " (replicate n "xpickle")+ tuple = intercalate ", " letters+ letters = map (:[]) $ take n ['a'..'z']+ constrainsts = intercalate ", " $ map oneConstr letters+ oneConstr a = "XmlPickler " ++ a++mkInstances :: String+mkInstances = intercalate "\n\n" $ mkInstance <$> [6..24]+-}++-- ------------------------------------------------------------++{- begin embeded test cases++-- ------------------------------------------------------------+--+-- a somewhat complex data structure+-- for representing programs of a simple+-- imperative language++type Program = Stmt++type StmtList = [Stmt]++data Stmt+ = Assign Ident Expr+ | Stmts StmtList+ | If Expr Stmt (Maybe Stmt)+ | While Expr Stmt+ deriving (Eq, Show)++type Ident = String++data Expr+ = IntConst Int+ | BoolConst Bool+ | Var Ident+ | UnExpr UnOp Expr+ | BinExpr Op Expr Expr+ deriving (Eq, Show)++data Op+ = Add | Sub | Mul | Div | Mod | Eq | Neq+ deriving (Eq, Ord, Enum, Show)++data UnOp+ = UPlus | UMinus | Neg+ deriving (Eq, Ord, Read, Show)++-- ------------------------------------------------------------+--+-- the pickler definition for the data types++-- the main pickler++xpProgram :: PU Program+xpProgram = xpElem "program" $+ xpAddNSDecl "" "program42" $+ xpickle++xpMissingRootElement :: PU Program+xpMissingRootElement = xpickle++instance XmlPickler UnOp where+ xpickle = xpPrim++instance XmlPickler Op where+ xpickle = xpWrap (toEnum, fromEnum) xpPrim++instance XmlPickler Expr where+ xpickle = xpAlt tag ps+ where+ tag (IntConst _ ) = 0+ tag (BoolConst _ ) = 1+ tag (Var _ ) = 2+ tag (UnExpr _ _ ) = 3+ tag (BinExpr _ _ _ ) = 4+ ps = [ xpWrap ( IntConst+ , \ (IntConst i ) -> i+ ) $+ ( xpElem "int" $+ xpAttr "value" $+ xpickle+ )++ , xpWrap ( BoolConst+ , \ (BoolConst b) -> b+ ) $+ ( xpElem "bool" $+ xpAttr "value" $+ xpWrap (toEnum, fromEnum) xpickle+ )++ , xpWrap ( Var+ , \ (Var n) -> n+ ) $+ ( xpElem "var" $+ xpAttr "name" $+ xpText+ )++ , xpWrap ( uncurry UnExpr+ , \ (UnExpr op e) -> (op, e)+ ) $+ ( xpElem "unex" $+ xpPair (xpAttr "op" xpickle)+ xpickle+ )++ , xpWrap ( uncurry3 $ BinExpr+ , \ (BinExpr op e1 e2) -> (op, e1, e2)+ ) $+ ( xpElem "binex" $+ xpTriple (xpAttr "op" xpickle)+ xpickle+ xpickle+ )+ ]++instance XmlPickler Stmt where+ xpickle = xpAlt tag ps+ where+ tag ( Assign _ _ ) = 0+ tag ( Stmts _ ) = 1+ tag ( If _ _ _ ) = 2+ tag ( While _ _ ) = 3+ ps = [ xpWrap ( uncurry Assign+ , \ (Assign n v) -> (n, v)+ ) $+ ( xpElem "assign" $+ xpFilterCont (neg $ hasName "comment" <+> isText) $ -- test case test7: remove uninteresting stuff+ xpPair (xpAttr "name" xpText)+ xpickle+ )+ , xpWrap ( Stmts+ , \ (Stmts sl) -> sl+ ) $+ ( xpElem "block" $+ xpList xpickle+ )+ , xpWrap ( uncurry3 If+ , \ (If c t e) -> (c, t, e)+ ) $+ ( xpElem "if" $+ xpTriple xpickle+ xpickle+ xpickle+ )+ , xpWrap ( uncurry While+ , \ (While c b) -> (c, b)+ ) $+ ( xpElem "while" $+ xpPair xpickle+ xpickle+ )+ ]++-- ------------------------------------------------------------+--+-- example programs++progs :: [Program]+progs = [p0, p1, p2]++p0, p1, p2 :: Program++p0 = Stmts [] -- the empty program++p1 = Stmts+ [ Assign i ( UnExpr UMinus ( IntConst (-22) ) )+ , Assign j ( IntConst 20 )+ , While+ ( BinExpr Neq ( Var i ) ( IntConst 0 ) )+ ( Stmts+ [ Assign i ( BinExpr Sub ( Var i ) ( IntConst 1 ) )+ , Assign j ( BinExpr Add ( Var j ) ( IntConst 1 ) )+ , If ( IntConst 0 ) (Stmts []) Nothing+ ]+ )+ ]+ where+ i = "i"+ j = "j"++p2 = Stmts+ [ Assign x (IntConst 6)+ , Assign y (IntConst 7)+ , Assign p (IntConst 0)+ , While+ ( BinExpr Neq (Var x) (IntConst 0) )+ ( If ( BinExpr Neq ( BinExpr Mod (Var x) (IntConst 2) ) (IntConst 0) )+ ( Stmts+ [ Assign x ( BinExpr Sub (Var x) (IntConst 1) )+ , Assign p ( BinExpr Add (Var p) (Var y) )+ ]+ )+ ( Just ( Stmts+ [ Assign x ( BinExpr Div (Var x) (IntConst 2) )+ , Assign y ( BinExpr Mul (Var y) (IntConst 2) )+ ]+ )+ )+ )+ ]+ where+ x = "x"+ y = "y"+ p = "p"++-- ------------------------------------------------------------++test0 = putStrLn . head . runLA+ ( xshow (arr (pickleDoc xpProgram)+ >>> getChildren+ )+ )++test0' f = runLA+ ( xshow (arr (pickleDoc xpProgram)+ >>> getChildren+ )+ >>>+ root [] [xread]+ >>>+ f+ )++test1' f = runLA+ ( xshow (arr (pickleDoc xpProgram)+ >>> getChildren+ )+ >>>+ root [] [xread]+ >>>+ f+ >>>+ arr (unpickleDoc' xpProgram)+ )++test1 = test0' (processTopDown (setQName (mkName "real") `X.when` hasName "int"))+test2 = test1' this+test3 = test1' (processTopDown (setQName (mkName "real") `X.when` hasName "int"))+test4 = test1' (processTopDown (setQName (mkName "xxx") `X.when` hasName "program"))+test5 = test1' (processTopDown (setQName (mkName "xxx") `X.when` hasName "assign"))+test6 = test1' (processTopDownWithAttrl (txt "xxx" `X.when` hasText (== "UMinus")))+test7 = test1' (processTopDown (insertComment `X.when` hasName "assign"))+ where insertComment = replaceChildren (getChildren <+> eelem "comment" <+> txt "zzz")++-- ------------------------------------------------------------++-- end embeded test cases -}
src/Text/XML/HXT/Arrow/ProcessDocument.hs view
@@ -27,45 +27,36 @@ ) where -import Control.Arrow -- arrow classes-import Control.Arrow.ArrowList-import Control.Arrow.ArrowIf-import Control.Arrow.ArrowTree-import Control.Arrow.ListArrow ( fromLA )-import Control.Arrow.NTreeEdit+import Control.Arrow+import Control.Arrow.ArrowIf+import Control.Arrow.ArrowList+import Control.Arrow.ArrowTree+import Control.Arrow.ListArrow (fromLA)+import Control.Arrow.NTreeEdit -import Text.XML.HXT.DOM.Interface+import Text.XML.HXT.DOM.Interface -import Text.XML.HXT.Arrow.XmlArrow-import Text.XML.HXT.Arrow.XmlState-import Text.XML.HXT.Arrow.XmlState.TypeDefs+import Text.XML.HXT.Arrow.XmlArrow+import Text.XML.HXT.Arrow.XmlState+import Text.XML.HXT.Arrow.XmlState.TypeDefs -import Text.XML.HXT.Arrow.ParserInterface ( parseXmlDoc- , parseHtmlDoc- )+import Text.XML.HXT.Arrow.ParserInterface (parseHtmlDoc,+ parseXmlDoc) -import Text.XML.HXT.Arrow.Edit ( transfAllCharRef- , substAllXHTMLEntityRefs- )+import Text.XML.HXT.Arrow.Edit (substAllXHTMLEntityRefs,+ transfAllCharRef) -import Text.XML.HXT.Arrow.GeneralEntitySubstitution- ( processGeneralEntities- )+import Text.XML.HXT.Arrow.GeneralEntitySubstitution (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.DTDValidation.Validation ( validate- , getDTDSubset- , generalEntitiesDefined- , transform- )+import Text.XML.HXT.Arrow.Namespace (propagateNamespaces, validateNamespaces)+import Text.XML.HXT.DTDValidation.Validation (generalEntitiesDefined,+ getDTDSubset,+ transform,+ validate) -- ------------------------------------------------------------ @@ -105,12 +96,12 @@ ( ifA (fromLA getDTDSubset) ( processDTDandEntities >>>- ( if validate' -- validation only possible if DTD there+ ( if validate' -- validation only possible if there is a DTD then validateDocument else this ) )- ( if validate' -- validation only consists of checking+ ( if validate' -- validation only consists of checking -- for undefined entity refs -- predefined XML entity refs are substituted -- in the XML parser into char refs@@ -138,7 +129,7 @@ ) >>> ( if substDTD- then ( processGeneralEntities -- DTD contains general entity definitions+ then ( processGeneralEntities -- DTD contains general entity definitions `when` fromLA generalEntitiesDefined )@@ -149,7 +140,7 @@ >>> transfAllCharRef -checkUndefinedEntityRefs :: IOStateArrow s XmlTree XmlTree+checkUndefinedEntityRefs :: IOStateArrow s XmlTree XmlTree checkUndefinedEntityRefs = deep isEntityRef >>>@@ -226,12 +217,12 @@ ) removeWarnings (warnings, withTagSoup')- | warnings = processTopDownWithAttrl -- remove warnings inserted by parser and entity subst+ | warnings = processTopDownWithAttrl -- remove warnings inserted by parser and entity subst filterErrorMsg- | withTagSoup' = this -- warnings are not generated in tagsoup+ | withTagSoup' = this -- warnings are not generated in tagsoup | otherwise = fromLA $- editNTreeA [isError :-> none] -- remove all warnings from document+ editNTreeA [isError :-> none] -- remove all warnings from document -- ------------------------------------------------------------
src/Text/XML/HXT/Arrow/ReadDocument.hs view
@@ -2,7 +2,7 @@ {- | Module : Text.XML.HXT.Arrow.ReadDocument- Copyright : Copyright (C) 2005 Uwe Schmidt+ Copyright : Copyright (C) 2005-2013 Uwe Schmidt License : MIT Maintainer : Uwe Schmidt (uwe@fh-wedel.de)@@ -21,21 +21,28 @@ , readString , readFromString , hread+ , hreadDoc , xread+ , xreadDoc ) where import Control.Arrow.ListArrows +import Data.Maybe ( fromMaybe )+import qualified Data.Map as M++ import Text.XML.HXT.DOM.Interface import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.Arrow.Edit ( canonicalizeAllNodes , canonicalizeForXPath+ , canonicalizeContents , rememberDTDAttrl , removeDocWhiteSpace )-import Text.XML.HXT.Arrow.ParserInterface+import qualified Text.XML.HXT.Arrow.ParserInterface as PI import Text.XML.HXT.Arrow.ProcessDocument ( getDocumentContents , parseXmlDocument , parseXmlDocumentWithExpat@@ -51,9 +58,10 @@ {- | the main document input filter -this filter can be configured by a list of configuration options, a value of type 'Text.XML.HXT.XmlState.TypeDefs.SysConfig'+this filter can be configured by a list of configuration options,+a value of type 'Text.XML.HXT.XmlState.TypeDefs.SysConfig' -for all available options see module 'Text.XML.HXT.XmlState.SystemConfig'+for all available options see module 'Text.XML.HXT.Arrow.XmlState.SystemConfig' - @withValidate yes\/no@ : switch on\/off DTD validation. Only for XML parsed documents, not for HTML parsing.@@ -68,7 +76,8 @@ - @withSubstHTMLEntities yes\/no@ : switch on\/off entity substitution for general entities defined in HTML validation. Default is @no@.- Switching this option on and the validation and substDTDEntities off can lead to faster parsing, in that case+ Switching this option on and the validation and substDTDEntities off can lead to faster parsing,+ in that case reading the DTD documents is not longer necessary, HTML general entities are still substituted. Only used with XML parsed documents, not with HTML parsing. @@ -82,27 +91,27 @@ - @withCheckNamespaces yes\/no@ : Switch on\/off namespace propagation and checking -- @withInputEncoding <encoding-spec>@ :+- @withInputEncoding \<encoding-spec\>@ : Set default encoding. - @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+ the source contains an @import Text.XML.HXT.TagSoup@. -- @withRelaxNG <schema.rng>@ :+- @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. -- @withCurl [<curl-option>...]@ :+- @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+ the source contains an @import Text.XML.HXT.Curl@. -- @withHTTP [<http-option>...]@ :+- @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+ the source contains an @import Text.XML.HXT.HTTP@. examples: @@ -118,7 +127,7 @@ > , withInputEncoding isoLatin1 > , withParseByMimeType yes > , withCurl []-> ] \"http:\/\/localhost\/test.php\"+> ] "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.@@ -200,10 +209,12 @@ >>> 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+ 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@@ -216,7 +227,8 @@ getSysVar (theParseByMimeType .&&&. theParseHTML .&&&. theAcceptedMimeTypes .&&&.- theRelaxValidate+ theRelaxValidate .&&&.+ theXmlSchemaValidate ) ) )@@ -227,16 +239,57 @@ >>> traceTree where+ processNoneEmptyDoc p+ = ifA (fromLA hasEmptyBody)+ (replaceChildren none)+ p+ where+ hasEmptyBody+ = hasAttrValue transferStatus (/= "200") -- test on empty response body for not o.k. responses+ `guards` -- e.g. 3xx status values+ ( neg getChildren+ <+>+ ( getChildren >>> isWhiteSpace )+ )+ getMimeType = getAttrValue transferMimeType >>^ stringToLower - processDoc mimeType (parseByMimeType, (parseHtml, (acceptedMimeTypes, validateWithRelax)))+ applyMimeTypeHandler mt+ = withoutUserState (applyMTH $< getSysVar theMimeTypeHandlers)+ where+ applyMTH mtTable+ = fromMaybe none $+ fmap (\ f -> processNoneEmptyDoc+ (traceMimeStart >>> f >>> traceMimeEnd)+ ) $+ M.lookup mt mtTable+ traceMimeStart+ = traceMsg 2 $+ "readDocument: calling user defined document parser"+ traceMimeEnd+ = traceMsg 2 $+ "readDocument: user defined document parser finished"++ processDoc mimeType options = traceMsg 1 (unwords [ "readDocument:", show src- , "(mime type:", show mimeType, ") will be processed"])+ , "(mime type:", show mimeType, ") will be processed"+ ]+ ) >>>- ( if isAcceptedMimeType acceptedMimeTypes mimeType- then ( ifA (fromLA hasEmptyBody)- ( replaceChildren none ) -- empty response, e.g. in if-modified-since request+ ( applyMimeTypeHandler mimeType -- try user defined document handlers+ `orElse`+ processDoc' mimeType options+ )++ processDoc' mimeType ( parseByMimeType+ , ( parseHtml+ , ( acceptedMimeTypes+ , ( validateWithRelax+ , validateWithXmlSchema+ ))))+ = ( if isAcceptedMimeType acceptedMimeTypes mimeType+ then ( processNoneEmptyDoc ( ( parse $< getSysVar (theValidate .&&&. theSubstDTDEntities .&&&. theSubstHTMLEntities .&&&.@@ -265,7 +318,7 @@ ) ) >>>- relax+ relaxOrXmlSchema ) else this )@@ -274,18 +327,10 @@ else ( traceMsg 1 (unwords [ "readDocument:", show src , "mime type:", show mimeType, "not accepted"]) >>>- replaceChildren none- ) -- remove contents of not accepted mimetype+ replaceChildren none -- remove contents of not accepted mimetype+ ) ) where- hasEmptyBody :: LA XmlTree XmlTree- hasEmptyBody = hasAttrValue transferStatus (/= "200") -- test on empty response body for not o.k. responses- `guards` -- e.g. 3xx status values- ( neg getChildren- <+>- ( getChildren >>> isWhiteSpace )- )- isAcceptedMimeType :: [String] -> String -> Bool isAcceptedMimeType mts mt | null mts@@ -305,7 +350,13 @@ (mi == mis || mis == "*") ) || r- parse (validate, (substDTD, (substHTML, (removeNoneXml, (withTagSoup', withExpat')))))+ parse ( validate+ , ( substDTD+ , ( substHTML+ , ( removeNoneXml+ , ( withTagSoup'+ , withExpat'+ ))))) | not isXmlOrHtml = if removeNoneXml then replaceChildren none -- don't parse, if mime type is not XML nor HTML else this -- but remove contents when option is set@@ -318,7 +369,11 @@ | isXml = if withExpat' then parseXmlDocumentWithExpat- else parseXmlDocument validate substDTD substHTML validateWithRelax+ else parseXmlDocument+ validate+ substDTD+ substHTML+ validateWithRelax -- parse as XML | otherwise = this -- suppress warning @@ -329,25 +384,35 @@ | withNamespaces ||- validateWithRelax = propagateAndValidateNamespaces -- RelaxNG requires correct namespaces+ validateWithRelax+ ||+ validateWithXmlSchema+ = propagateAndValidateNamespaces -- RelaxNG and XML Schema require correct namespaces | otherwise = this canonicalize (preserveCmt, (canonicalize', withTagSoup')) | withTagSoup' = this -- tagsoup already removes redundant stuff- | validateWithRelax = canonicalizeAllNodes+ | validateWithRelax+ ||+ validateWithXmlSchema = canonicalizeAllNodes -- no comments in schema validation+ | canonicalize' && preserveCmt = canonicalizeForXPath | canonicalize' = canonicalizeAllNodes | otherwise = this - relax+ relaxOrXmlSchema+ | validateWithXmlSchema = withoutUserState $< getSysVar theXmlSchemaValidator | validateWithRelax = withoutUserState $< getSysVar theRelaxValidator | otherwise = this whitespace (removeWS, withTagSoup')- | removeWS+ | ( removeWS+ ||+ validateWithXmlSchema -- XML Schema does not like WS+ ) && not withTagSoup' = removeDocWhiteSpace -- tagsoup already removes whitespace | otherwise = this@@ -373,8 +438,9 @@ -- | -- the arrow version of 'readDocument', the arrow input is the source URI -readFromDocument :: SysConfigList -> IOStateArrow s String XmlTree-readFromDocument config = applyA ( arr $ readDocument config )+readFromDocument :: SysConfigList -> IOStateArrow s String XmlTree+readFromDocument config+ = applyA ( arr $ readDocument config ) -- ------------------------------------------------------------ @@ -382,22 +448,25 @@ -- read a document that is stored in a normal Haskell String -- -- the same function as readDocument, but the parameter forms the input.--- All options available for 'readDocument' are applicable for readString.+-- All options available for 'readDocument' are applicable for readString,+-- except input encoding options. ----- Default encoding: No encoding is done, the String argument is taken as Unicode string+-- Encoding: No decoding is done, the String argument is taken as Unicode string+-- All decoding must be done before calling readString, even if the+-- XML document contains an encoding spec. -readString :: SysConfigList -> String -> IOStateArrow s b XmlTree+readString :: SysConfigList -> String -> IOStateArrow s b XmlTree readString config content- = readDocument (withInputEncoding unicodeString : config)- (stringProtocol ++ content)+ = readDocument config (stringProtocol ++ content) -- ------------------------------------------------------------ -- | -- the arrow version of 'readString', the arrow input is the source URI -readFromString :: SysConfigList -> IOStateArrow s String XmlTree-readFromString config = applyA ( arr $ readString config )+readFromString :: SysConfigList -> IOStateArrow s String XmlTree+readFromString config+ = applyA ( arr $ readString config ) -- ------------------------------------------------------------ @@ -410,32 +479,57 @@ -- This is a simpler version of 'readFromString' without any options, -- but it does not run in the IO monad. -hread :: ArrowXml a => a String XmlTree-hread = fromLA $- parseHtmlContent -- substHtmlEntityRefs is done in parser- >>> -- as well as subst HTML char refs- editNTreeA [isError :-> none] -- ignores all errors+hread :: ArrowXml a => a String XmlTree+hread+ = fromLA $+ PI.hread -- substHtmlEntityRefs is done in parser+ >>> -- as well as subst HTML char refs+ editNTreeA [isError :-> none] -- ignores all errors+ >>>+ canonicalizeContents -- combine text nodes, substitute char refs+ -- comments are not removed -{- no longer neccesary, text nodes are merged in parser- >>>- canonicalizeContents--}+-- | like hread, but accepts a whole document, not a HTML content +hreadDoc :: ArrowXml a => a String XmlTree+hreadDoc+ = fromLA $+ root [] [PI.hreadDoc] -- substHtmlEntityRefs is done in parser+ >>> -- as well as subst HTML char refs+ editNTreeA [isError :-> none] -- ignores all errors+ >>>+ canonicalizeForXPath -- remove DTD spec and text in content of root node+ -- and do a canonicalizeContents+ >>>+ getChildren+ -- ------------------------------------------------------------ -- |--- parse a string as XML content, substitute all predefined XML entity refs and canonicalize tree+-- parse a string as XML CONTENT, (no xml decl or doctype decls are allowed),+-- substitute all predefined XML entity refs and canonicalize tree -- This xread arrow delegates all work to the xread parser function in module XmlParsec -xread :: ArrowXml a => a String XmlTree-xread = parseXmlContent+xread :: ArrowXml a => a String XmlTree+xread = PI.xreadCont++-- |+-- a more general version of xread which+-- parses a whole document including a prolog+-- (xml decl, doctype decl) and processing+-- instructions. Doctype decls remain uninterpreted,+-- but are in the list of results trees.++xreadDoc :: ArrowXml a => a String XmlTree+xreadDoc = PI.xreadDoc+ {- -- the old version, where the parser does not subst char refs and cdata xread = root [] [parseXmlContent] -- substXmlEntityRefs is done in parser >>> canonicalizeContents >>> getChildren--}+-- -} -- ------------------------------------------------------------
src/Text/XML/HXT/Arrow/XmlArrow.hs view
@@ -153,7 +153,7 @@ {-# INLINE hasQName #-} -- |- -- test whether a node has a specific name (prefix:localPart ore localPart),+ -- test whether a node has a specific name (prefix:localPart or localPart), -- generally useful, even without namespace handling hasName :: String -> a XmlTree XmlTree hasName n = (getName >>> isA (== n)) `guards` this@@ -277,17 +277,17 @@ mkelem n afs cfs = mkElement (mkName n) (catA afs) (catA cfs) {-# INLINE mkelem #-} - -- | convenient arrow for element constrution with attributes but without content, simple variant of 'mkelem' and 'mkElement'+ -- | convenient arrow for element construction with attributes but without content, simple variant of 'mkelem' and 'mkElement' aelem :: String -> [a n XmlTree] -> a n XmlTree aelem n afs = catA afs >. \ al -> XN.mkElement (mkName n) al [] {-# INLINE aelem #-} - -- | convenient arrow for simple element constrution without attributes, simple variant of 'mkelem' and 'mkElement'+ -- | convenient arrow for simple element construction without attributes, simple variant of 'mkelem' and 'mkElement' selem :: String -> [a n XmlTree] -> a n XmlTree selem n cfs = catA cfs >. XN.mkElement (mkName n) [] {-# INLINE selem #-} - -- | convenient arrow for constrution of empty elements without attributes, simple variant of 'mkelem' and 'mkElement'+ -- | convenient arrow for construction of empty elements without attributes, simple variant of 'mkelem' and 'mkElement' eelem :: String -> a n XmlTree eelem n = constA (XN.mkElement (mkName n) [] []) {-# INLINE eelem #-}@@ -302,7 +302,7 @@ qattr = mkAttr {-# INLINE qattr #-} - -- | convenient arrow for attribute constrution, simple variant of 'mkAttr'+ -- | convenient arrow for attribute construction, simple variant of 'mkAttr' attr :: String -> a n XmlTree -> a n XmlTree attr = mkAttr . mkName {-# INLINE attr #-}
src/Text/XML/HXT/Arrow/XmlOptions.hs view
@@ -241,7 +241,7 @@ -- ------------------------------------------------------------ -- |--- select options from a predefined list of option desciptions+-- select options from a predefined list of option descriptions selectOptions :: [String] -> [OptDescr a] -> [OptDescr a] selectOptions ol os
src/Text/XML/HXT/Arrow/XmlRegex.hs view
@@ -11,7 +11,7 @@ Regular Expression Matcher working on lists of XmlTrees - It's intendet to import this module with an explicit+ It's intended to import this module with an explicit import declaration for not spoiling the namespace with these somewhat special arrows @@ -24,6 +24,7 @@ , mkZero , mkUnit , mkPrim+ , mkPrim' , mkPrimA , mkDot , mkStar@@ -34,6 +35,9 @@ , mkRep , mkRng , mkOpt+ , mkPerm+ , mkPerms+ , mkMerge , nullable , delta , matchXmlRegex@@ -45,11 +49,12 @@ ) where -import Control.Arrow.ListArrows+import Control.Arrow.ListArrows -import Data.Maybe+import Data.Maybe -import Text.XML.HXT.DOM.Interface+import Text.XML.HXT.DOM.Interface+import Text.XML.HXT.DOM.ShowXml (xshow) -- ------------------------------------------------------------ -- the exported regex arrows@@ -88,13 +93,15 @@ data XmlRegex = Zero String | Unit- | Sym (XmlTree -> Bool)+ | Sym (XmlTree -> Bool) String -- optional external repr. of predicate | Dot- | Star XmlRegex- | Alt XmlRegex XmlRegex- | Seq XmlRegex XmlRegex- | Rep Int XmlRegex -- 1 or more repetitions- | Rng Int Int XmlRegex -- n..m repetitions+ | Star XmlRegex+ | Alt XmlRegex XmlRegex+ | Seq XmlRegex XmlRegex+ | Rep Int XmlRegex -- 1 or more repetitions+ | Rng Int Int XmlRegex -- n..m repetitions+ | Perm XmlRegex XmlRegex+ | Merge XmlRegex XmlRegex -- ------------------------------------------------------------ @@ -106,7 +113,7 @@ instance Inv XmlRegex where inv (Zero _) = True inv Unit = True- inv (Sym p) = p holds for some XmlTrees+ inv (Sym p _) = p holds for some XmlTrees inv Dot = True inv (Star e) = inv e inv (Alt e1 e2) = inv e1 &&@@ -116,6 +123,8 @@ inv (Rep i e) = i > 0 && inv e inv (Rng i j e) = (i < j || (i == j && i > 1)) && inv e+ inv (Perm e1 e2) = inv e1 &&+ inv e2 -} -- ------------------------------------------------------------ --@@ -128,8 +137,11 @@ mkUnit = Unit mkPrim :: (XmlTree -> Bool) -> XmlRegex-mkPrim = Sym+mkPrim p = Sym p "" +mkPrim' :: (XmlTree -> Bool) -> String -> XmlRegex+mkPrim' = Sym+ mkPrimA :: LA XmlTree XmlTree -> XmlRegex mkPrimA a = mkPrim (not . null . runLA a) @@ -155,9 +167,14 @@ mkAlt (Zero _) e2 = e2 -- {} u e2 = e2 mkAlt e1@(Star Dot) _e2 = e1 -- A* u e1 = A* mkAlt _e1 e2@(Star Dot) = e2 -- e1 u A* = A*-mkAlt (Sym p1) (Sym p2) = mkPrim $ \ x -> p1 x || p2 x -- melting of predicates-mkAlt e1 e2@(Sym _) = mkAlt e2 e1 -- symmetry: predicates always first-mkAlt e1@(Sym _) (Alt e2@(Sym _) e3) = mkAlt (mkAlt e1 e2) e3 -- prepare melting of predicates+mkAlt (Sym p1 e1) (Sym p2 e2) = mkPrim' (\ x -> p1 x || p2 x) (e e1 e2) -- melting of predicates+ where+ e "" x2 = x2+ e x1 "" = x1+ e x1 x2 = x1 ++ "|" ++ x2+mkAlt e1 e2@(Sym _ _) = mkAlt e2 e1 -- symmetry: predicates always first+mkAlt e1@(Sym _ _) (Alt e2@(Sym _ _) e3)+ = mkAlt (mkAlt e1 e2) e3 -- prepare melting of predicates mkAlt (Alt e1 e2) e3 = mkAlt e1 (mkAlt e2 e3) -- associativity mkAlt e1 e2 = Alt e1 e2 @@ -195,12 +212,30 @@ mkOpt :: XmlRegex -> XmlRegex mkOpt = mkRng 0 1 +mkPerm :: XmlRegex -> XmlRegex -> XmlRegex+mkPerm e1@(Zero _) _ = e1+mkPerm _ e2@(Zero _) = e2+mkPerm Unit e2 = e2+mkPerm e1 Unit = e1+mkPerm e1 e2 = Perm e1 e2++mkPerms :: [XmlRegex] -> XmlRegex+mkPerms = foldr mkPerm mkUnit++mkMerge :: XmlRegex -> XmlRegex -> XmlRegex+mkMerge e1@(Zero _) _ = e1+mkMerge _ e2@(Zero _) = e2+mkMerge Unit e2 = e2+mkMerge e1 Unit = e1+mkMerge e1 e2 = Merge e1 e2+ -- ------------------------------------------------------------ instance Show XmlRegex where show (Zero s) = "{err:" ++ s ++ "}" show Unit = "()"- show (Sym _p) = "{single tree pred}"+ show (Sym _p "") = "<pred>"+ show (Sym _p r ) = r show Dot = "." show (Star e) = "(" ++ show e ++ ")*" show (Alt e1 e2) = "(" ++ show e1 ++ "|" ++ show e2 ++ ")"@@ -209,13 +244,28 @@ show (Rep i e) = "(" ++ show e ++ "){" ++ show i ++ ",}" show (Rng 0 1 e) = "(" ++ show e ++ ")?" show (Rng i j e) = "(" ++ show e ++ "){" ++ show i ++ "," ++ show j ++ "}"+ show (Perm e1 e2) = "(" ++ show e1 ++ show e2 ++ "|" ++ show e2 ++ show e1 ++ ")"+ show (Merge e1 e2) = "(" ++ show e1 ++ "&" ++ show e2 ++ ")" -- ------------------------------------------------------------ +unexpected :: XmlTree -> String -> String+unexpected t e = emsg e ++ (cut 80 . xshow) [t]+ where+ emsg "" = "unexpected: "+ emsg s = "expected: " ++ s ++ ", but got: "+ cut n s+ | null rest = s'+ | otherwise = s' ++ "..."+ where+ (s', rest) = splitAt n s++-- ------------------------------------------------------------+ nullable :: XmlRegex -> Bool nullable (Zero _) = False nullable Unit = True-nullable (Sym _p) = False -- assumption: p holds for at least one tree+nullable (Sym _p _) = False -- assumption: p holds for at least one tree nullable Dot = False nullable (Star _) = True nullable (Alt e1 e2) = nullable e1 ||@@ -225,25 +275,34 @@ nullable (Rep _i e) = nullable e nullable (Rng i _ e) = i == 0 || nullable e+nullable (Perm e1 e2) = nullable e1 &&+ nullable e2+nullable (Merge e1 e2) = nullable e1 &&+ nullable e2 -- ------------------------------------------------------------ delta :: XmlRegex -> XmlTree -> XmlRegex-delta e@(Zero _) _ = e-delta Unit c = mkZero $- "unexpected char " ++ show c-delta (Sym p) c+delta e@(Zero _) _ = e+delta Unit c = mkZero $ unexpected c ""+delta (Sym p e) c | p c = mkUnit- | otherwise = mkZero $- "unexpected tree " ++ show c-delta Dot _ = mkUnit-delta e@(Star e1) c = mkSeq (delta e1 c) e-delta (Alt e1 e2) c = mkAlt (delta e1 c) (delta e2 c)-delta (Seq e1 e2) c+ | otherwise = mkZero $ unexpected c e+delta Dot _ = mkUnit+delta e@(Star e1) c = mkSeq (delta e1 c) e+delta (Alt e1 e2) c = mkAlt (delta e1 c) (delta e2 c)+delta (Seq e1 e2) c | nullable e1 = mkAlt (mkSeq (delta e1 c) e2) (delta e2 c) | otherwise = mkSeq (delta e1 c) e2-delta (Rep i e) c = mkSeq (delta e c) (mkRep (i-1) e)-delta (Rng i j e) c = mkSeq (delta e c) (mkRng ((i-1) `max` 0) (j-1) e)+delta (Rep i e) c = mkSeq (delta e c) (mkRep (i-1) e)+delta (Rng i j e) c = mkSeq (delta e c) (mkRng ((i-1) `max` 0) (j-1) e)+delta (Perm e1 e2) c = case e1' of+ (Zero _) -> mkPerm e1 (delta e2 c)+ _ -> mkPerm e1' e2+ where+ e1' = delta e1 c+delta (Merge e1 e2) c = mkAlt (mkMerge (delta e1 c) e2)+ (mkMerge e1 (delta e2 c)) -- ------------------------------------------------------------
src/Text/XML/HXT/Arrow/XmlState.hs view
@@ -104,7 +104,7 @@ , setMimeTypeTable , setMimeTypeTableFromFile - , -- System Configuration and options+ , -- * System Configuration and Options yes , no @@ -125,6 +125,7 @@ , withInputOption , withInputOptions , withMimeTypeFile+ , withMimeTypeHandler , withNoEmptyElemFor , withXmlPi , withOutputEncoding
src/Text/XML/HXT/Arrow/XmlState/RunIOStateArrow.hs view
@@ -21,6 +21,7 @@ import Control.Arrow.ArrowList import Control.Arrow.IOStateListArrow +import Data.Map ( empty ) import Text.XML.HXT.DOM.Interface import Text.XML.HXT.Arrow.XmlArrow@@ -94,6 +95,7 @@ , xioParseConfig = initialParseConfig , xioOutputConfig = initialOutputConfig , xioRelaxConfig = initialRelaxConfig+ , xioXmlSchemaConfig = initialXmlSchemaConfig , xioCacheConfig = initialCacheConfig } @@ -111,6 +113,7 @@ initialParseConfig :: XIOParseConfig initialParseConfig = XIOPcfg { xioMimeTypes = defaultMimeTypeTable+ , xioMimeTypeHandlers = empty , xioMimeTypeFile = "" , xioAcceptedMimeTypes = [] , xioFileMimeType = ""@@ -156,6 +159,13 @@ , xioRelaxValidator = dummyRelaxValidator } +initialXmlSchemaConfig :: XIOXmlSchemaConfig+initialXmlSchemaConfig = XIOScc+ { xioXmlSchemaValidate = False+ , xioXmlSchemaSchema = ""+ , xioXmlSchemaValidator = dummyXmlSchemaValidator+ }+ initialCacheConfig :: XIOCacheConfig initialCacheConfig = XIOCch { xioBinaryCompression = id@@ -206,6 +216,14 @@ [ "RelaxNG validator not configured," , "please install package hxt-relaxng" , " and use 'withRelaxNG' config option from this package"+ ]++dummyXmlSchemaValidator :: IOSArrow b b+dummyXmlSchemaValidator = issueFatal $+ unlines $+ [ "XML Schema validator not configured,"+ , "please install package hxt-xmlschema"+ , " and use 'withXmlSchema' config option from this package" ] dummyCacheRead :: String -> IOSArrow b b
src/Text/XML/HXT/Arrow/XmlState/SystemConfig.hs view
@@ -20,6 +20,8 @@ import Control.Arrow +import Data.Map ( insert )+ import Text.XML.HXT.DOM.Interface import Text.XML.HXT.Arrow.XmlState.ErrorHandling@@ -29,19 +31,29 @@ -- config options --- | @withTace level@ : system option, set the trace level, (0..4)+-- | @withTrace level@ : system option, set the trace level, (0..4) withTrace :: Int -> SysConfig withTrace = setS theTraceLevel --- | @withSysAttr key value@ : store an arbitarty key value pair in system state+-- | @withSysAttr key value@ : store an arbitrary key value pair in system state withSysAttr :: String -> String -> SysConfig withSysAttr n v = chgS theAttrList (addEntry n v) +-- | Specify the set of accepted mime types.+--+-- All contents of documents for which the mime type is not found in this list+-- are discarded.+ withAcceptedMimeTypes :: [String] -> SysConfig withAcceptedMimeTypes = setS theAcceptedMimeTypes +-- | Specify a content handler for documents of a given mime type++withMimeTypeHandler :: String -> IOSArrow XmlTree XmlTree -> SysConfig+withMimeTypeHandler mt pa = chgS theMimeTypeHandlers $ insert mt pa+ -- | @withMimeTypeFile filename@ : input option, -- set the mime type table for @file:@ documents by given file. -- The format of this config file must be in the syntax of a debian linux \"mime.types\" config file@@ -208,7 +220,8 @@ withOutputHTML :: SysConfig withOutputHTML = setS theOutputFmt HTMLoutput --- | Write XML: quote only special XML chars, don't substitute chars by HTML entities, and don\'t generate empty elements for HTML elements,+-- | Write XML: quote only special XML chars, don't substitute chars by HTML entities,+-- and don\'t generate empty elements for HTML elements, -- which may contain any contents, e.g. @<script src=...></script>@ instead of @<script src=... />@ withOutputXHTML :: SysConfig
src/Text/XML/HXT/Arrow/XmlState/TypeDefs.hs view
@@ -39,20 +39,18 @@ ) where -import Control.Arrow -- arrow classes-import Control.Arrow.ArrowList-import Control.Arrow.IOStateListArrow-import Control.DeepSeq+import Control.Arrow+import Control.Arrow.ArrowList+import Control.Arrow.IOStateListArrow+import Control.DeepSeq -import Data.ByteString.Lazy ( ByteString )-import Data.Char ( isDigit )-import Data.Function.Selector ( Selector(..)- , chgS- , idS- , (.&&&.)- )+import Data.ByteString.Lazy (ByteString)+import Data.Char (isDigit)+import Data.Function.Selector (Selector (..), chgS, idS,+ (.&&&.))+import qualified Data.Map as M -import Text.XML.HXT.DOM.Interface+import Text.XML.HXT.DOM.Interface -- ------------------------------------------------------------ {- datatypes -}@@ -61,8 +59,8 @@ -- state datatype consists of a system state and a user state -- the user state is not fixed -data XIOState us = XIOState { xioSysState :: ! XIOSysState- , xioUserState :: ! us+data XIOState us = XIOState { xioSysState :: !XIOSysState+ , xioUserState :: !us } instance (NFData us) => NFData (XIOState us) where@@ -154,102 +152,112 @@ -- predefined system state data type with all components for the -- system functions, like trace, error handling, ... -data XIOSysState = XIOSys { xioSysWriter :: ! XIOSysWriter- , xioSysEnv :: ! XIOSysEnv+data XIOSysState = XIOSys { xioSysWriter :: !XIOSysWriter+ , xioSysEnv :: !XIOSysEnv } -instance NFData XIOSysState -- all fields of interest are strict+instance NFData XIOSysState where+ rnf x = seq x () -- all fields of interest are strict -data XIOSysWriter = XIOwrt { xioErrorStatus :: ! Int- , xioErrorMsgList :: ! XmlTrees- , xioExpatErrors :: IOSArrow XmlTree XmlTree- , xioRelaxNoOfErrors :: ! Int- , xioRelaxDefineId :: ! Int- , xioRelaxAttrList :: AssocList String XmlTrees+data XIOSysWriter = XIOwrt { xioErrorStatus :: !Int+ , xioErrorMsgList :: !XmlTrees+ , xioExpatErrors :: IOSArrow XmlTree XmlTree+ , xioRelaxNoOfErrors :: !Int+ , xioRelaxDefineId :: !Int+ , xioRelaxAttrList :: AssocList String XmlTrees } -data XIOSysEnv = XIOEnv { xioTraceLevel :: ! Int- , xioTraceCmd :: Int -> String -> IO ()- , xioErrorMsgHandler :: String -> IO ()- , xioErrorMsgCollect :: ! Bool- , xioBaseURI :: ! String- , xioDefaultBaseURI :: ! String- , xioAttrList :: ! Attributes- , xioInputConfig :: ! XIOInputConfig- , xioParseConfig :: ! XIOParseConfig- , xioOutputConfig :: ! XIOOutputConfig- , xioRelaxConfig :: ! XIORelaxConfig- , xioCacheConfig :: ! XIOCacheConfig+data XIOSysEnv = XIOEnv { xioTraceLevel :: !Int+ , xioTraceCmd :: Int -> String -> IO ()+ , xioErrorMsgHandler :: String -> IO ()+ , xioErrorMsgCollect :: !Bool+ , xioBaseURI :: !String+ , xioDefaultBaseURI :: !String+ , xioAttrList :: !Attributes+ , xioInputConfig :: !XIOInputConfig+ , xioParseConfig :: !XIOParseConfig+ , xioOutputConfig :: !XIOOutputConfig+ , xioRelaxConfig :: !XIORelaxConfig+ , xioXmlSchemaConfig :: !XIOXmlSchemaConfig+ , xioCacheConfig :: !XIOCacheConfig } -data XIOInputConfig = XIOIcgf { xioStrictInput :: ! Bool- , xioEncodingErrors :: ! Bool- , xioInputEncoding :: String- , xioHttpHandler :: IOSArrow XmlTree XmlTree- , xioInputOptions :: ! Attributes- , xioRedirect :: ! Bool- , xioProxy :: String+data XIOInputConfig = XIOIcgf { xioStrictInput :: !Bool+ , xioEncodingErrors :: !Bool+ , xioInputEncoding :: String+ , xioHttpHandler :: IOSArrow XmlTree XmlTree+ , xioInputOptions :: !Attributes+ , xioRedirect :: !Bool+ , xioProxy :: String } -data XIOParseConfig = XIOPcfg { xioMimeTypes :: MimeTypeTable- , xioMimeTypeFile :: String- , xioAcceptedMimeTypes :: [String]- , xioFileMimeType :: String- , xioWarnings :: ! Bool- , xioRemoveWS :: ! Bool- , xioParseByMimeType :: ! Bool- , xioParseHTML :: ! Bool- , xioLowerCaseNames :: ! Bool- , xioPreserveComment :: ! Bool- , xioValidate :: ! Bool- , xioSubstDTDEntities :: ! Bool- , xioSubstHTMLEntities :: ! Bool- , xioCheckNamespaces :: ! Bool- , xioCanonicalize :: ! Bool- , xioIgnoreNoneXmlContents :: ! Bool- , xioTagSoup :: ! Bool- , xioTagSoupParser :: IOSArrow XmlTree XmlTree- , xioExpat :: ! Bool- , xioExpatParser :: IOSArrow XmlTree XmlTree+data XIOParseConfig = XIOPcfg { xioMimeTypes :: MimeTypeTable+ , xioMimeTypeHandlers :: MimeTypeHandlers+ , xioMimeTypeFile :: String+ , xioAcceptedMimeTypes :: [String]+ , xioFileMimeType :: String+ , xioWarnings :: !Bool+ , xioRemoveWS :: !Bool+ , xioParseByMimeType :: !Bool+ , xioParseHTML :: !Bool+ , xioLowerCaseNames :: !Bool+ , xioPreserveComment :: !Bool+ , xioValidate :: !Bool+ , xioSubstDTDEntities :: !Bool+ , xioSubstHTMLEntities :: !Bool+ , xioCheckNamespaces :: !Bool+ , xioCanonicalize :: !Bool+ , xioIgnoreNoneXmlContents :: !Bool+ , xioTagSoup :: !Bool+ , xioTagSoupParser :: IOSArrow XmlTree XmlTree+ , xioExpat :: !Bool+ , xioExpatParser :: IOSArrow XmlTree XmlTree } -data XIOOutputConfig = XIOOcfg { xioIndent :: ! Bool- , xioOutputEncoding :: ! String- , xioOutputFmt :: ! XIOXoutConfig- , xioXmlPi :: ! Bool- , xioNoEmptyElemFor :: ! [String]- , xioAddDefaultDTD :: ! Bool- , xioTextMode :: ! Bool- , xioShowTree :: ! Bool- , xioShowHaskell :: ! Bool+data XIOOutputConfig = XIOOcfg { xioIndent :: !Bool+ , xioOutputEncoding :: !String+ , xioOutputFmt :: !XIOXoutConfig+ , xioXmlPi :: !Bool+ , xioNoEmptyElemFor :: ![String]+ , xioAddDefaultDTD :: !Bool+ , xioTextMode :: !Bool+ , xioShowTree :: !Bool+ , xioShowHaskell :: !Bool } data XIOXoutConfig = XMLoutput | XHTMLoutput | HTMLoutput | PLAINoutput deriving (Eq) -data XIORelaxConfig = XIORxc { xioRelaxValidate :: ! Bool- , xioRelaxSchema :: String- , xioRelaxCheckRestr :: ! Bool- , xioRelaxValidateExtRef :: ! Bool- , xioRelaxValidateInclude :: ! Bool- , xioRelaxCollectErrors :: ! Bool- , xioRelaxValidator :: IOSArrow XmlTree XmlTree+data XIORelaxConfig = XIORxc { xioRelaxValidate :: !Bool+ , xioRelaxSchema :: String+ , xioRelaxCheckRestr :: !Bool+ , xioRelaxValidateExtRef :: !Bool+ , xioRelaxValidateInclude :: !Bool+ , xioRelaxCollectErrors :: !Bool+ , xioRelaxValidator :: IOSArrow XmlTree XmlTree } -data XIOCacheConfig = XIOCch { xioBinaryCompression :: CompressionFct- , xioBinaryDeCompression :: DeCompressionFct- , xioWithCache :: ! Bool- , xioCacheDir :: ! String- , xioDocumentAge :: ! Int- , xioCache404Err :: ! Bool- , xioCacheRead :: String -> IOSArrow XmlTree XmlTree- , xioStrictDeserialize :: ! Bool+data XIOXmlSchemaConfig = XIOScc { xioXmlSchemaValidate :: !Bool+ , xioXmlSchemaSchema :: String+ , xioXmlSchemaValidator :: IOSArrow XmlTree XmlTree } +data XIOCacheConfig = XIOCch { xioBinaryCompression :: CompressionFct+ , xioBinaryDeCompression :: DeCompressionFct+ , xioWithCache :: !Bool+ , xioCacheDir :: !String+ , xioDocumentAge :: !Int+ , xioCache404Err :: !Bool+ , xioCacheRead :: String -> IOSArrow XmlTree XmlTree+ , xioStrictDeserialize :: !Bool+ }++type MimeTypeHandlers = M.Map String (IOSArrow XmlTree XmlTree)+ type CompressionFct = ByteString -> ByteString type DeCompressionFct = ByteString -> ByteString -type SysConfig = XIOSysState -> XIOSysState-type SysConfigList = [SysConfig]+type SysConfig = XIOSysState -> XIOSysState+type SysConfigList = [SysConfig] -- ---------------------------------------- @@ -491,15 +499,45 @@ , setS = \ x s -> s { xioRelaxCollectErrors = x} } -theRelaxValidator :: Selector XIOSysState (IOSArrow XmlTree XmlTree)-theRelaxValidator = theRelaxConfig- >>>- S { getS = xioRelaxValidator- , setS = \ x s -> s { xioRelaxValidator = x}- }+theRelaxValidator :: Selector XIOSysState (IOSArrow XmlTree XmlTree)+theRelaxValidator = theRelaxConfig+ >>>+ S { getS = xioRelaxValidator+ , setS = \ x s -> s { xioRelaxValidator = x}+ } -- ---------------------------------------- +theXmlSchemaConfig :: Selector XIOSysState XIOXmlSchemaConfig+theXmlSchemaConfig = theSysEnv+ >>>+ S { getS = xioXmlSchemaConfig+ , setS = \ x s -> s { xioXmlSchemaConfig = x}+ }++theXmlSchemaValidate :: Selector XIOSysState Bool+theXmlSchemaValidate = theXmlSchemaConfig+ >>>+ S { getS = xioXmlSchemaValidate+ , setS = \ x s -> s { xioXmlSchemaValidate = x}+ }++theXmlSchemaSchema :: Selector XIOSysState String+theXmlSchemaSchema = theXmlSchemaConfig+ >>>+ S { getS = xioXmlSchemaSchema+ , setS = \ x s -> s { xioXmlSchemaSchema = x}+ }++theXmlSchemaValidator :: Selector XIOSysState (IOSArrow XmlTree XmlTree)+theXmlSchemaValidator = theXmlSchemaConfig+ >>>+ S { getS = xioXmlSchemaValidator+ , setS = \ x s -> s { xioXmlSchemaValidator = x}+ }++-- ----------------------------------------+ theParseConfig :: Selector XIOSysState XIOParseConfig theParseConfig = theSysEnv >>>@@ -566,6 +604,13 @@ , setS = \ x s -> s { xioMimeTypes = x } } +theMimeTypeHandlers :: Selector XIOSysState MimeTypeHandlers+theMimeTypeHandlers = theParseConfig+ >>>+ S { getS = xioMimeTypeHandlers+ , setS = \ x s -> s { xioMimeTypeHandlers = x }+ }+ theMimeTypeFile :: Selector XIOSysState String theMimeTypeFile = theParseConfig >>>@@ -857,9 +902,9 @@ toInt :: Int -> String -> Int toInt def s- | not (null s)- &&- all isDigit s = read s- | otherwise = def+ | not (null s)+ &&+ all isDigit s = read s+ | otherwise = def -- ------------------------------------------------------------
src/Text/XML/HXT/Arrow/XmlState/URIHandling.hs view
@@ -166,7 +166,8 @@ = do base' <- parseURIReference' base uri' <- parseURIReference' uri- abs' <- nonStrictRelativeTo uri' base'+ -- abs' <- nonStrictRelativeTo uri' base'+ let abs' = nonStrictRelativeTo uri' base' return $ show abs' -- | arrow variant of 'expandURIString', fails if 'expandURIString' returns Nothing
src/Text/XML/HXT/DOM/QualifiedName.hs view
@@ -82,30 +82,27 @@ import Debug.Trace -} -import Control.Arrow ( (***) )+import Control.Arrow ((***)) import Control.DeepSeq import Control.FlatSeq import Data.AssocList import Data.Binary-import Data.Char ( toLower )+import Data.Char (toLower) import Data.IORef-import Data.List ( isPrefixOf )-import qualified Data.Map as M+import Data.List (isPrefixOf)+import qualified Data.Map as M import Data.Typeable -import System.IO.Unsafe ( unsafePerformIO )+import System.IO.Unsafe (unsafePerformIO) -import Text.XML.HXT.DOM.XmlKeywords ( a_xml- , a_xmlns- , xmlNamespace- , xmlnsNamespace- )+import Text.XML.HXT.DOM.XmlKeywords (a_xml, a_xmlns,+ xmlNamespace,+ xmlnsNamespace) -import Data.Char.Properties.XMLCharProps ( isXmlNCNameStartChar- , isXmlNCNameChar- )+import Data.Char.Properties.XMLCharProps (isXmlNCNameChar,+ isXmlNCNameStartChar) -- ----------------------------------------------------------------------------- @@ -113,8 +110,8 @@ -- Names are always reduced to normal form, and they are stored internally in a name cache -- for sharing equal names by the same data structure -data XName = XN { _idXN :: ! Int -- for optimization of equality test, see Eq instance- , unXN :: String+data XName = XN { _idXN :: !Int -- for optimization of equality test, see Eq instance+ , unXN :: String } deriving (Typeable) @@ -161,9 +158,9 @@ -- When dealing with namespaces, the document tree must be processed by 'Text.XML.HXT.Arrow.Namespace.propagateNamespaces' -- to split names of structure \"prefix:localPart\" and label the name with the apropriate namespace uri -data QName = QN { localPart' :: ! XName- , namePrefix' :: ! XName- , namespaceUri' :: ! XName+data QName = QN { localPart' :: !XName+ , namePrefix' :: !XName+ , namespaceUri' :: !XName } deriving (Typeable) @@ -181,11 +178,20 @@ && -- and prefixes are not set or they are equal px1 == px2 -instance NFData QName+instance Ord QName where+ compare (QN lp1 px1 ns1) (QN lp2 px2 ns2)+ | isNullXName ns1 && isNullXName ns2 -- no namespaces set: px is significant+ = compare (px1, lp1) (px2, lp2)+ | otherwise -- namespace aware cmp: ns is significant, px is irrelevant+ = compare (lp1, ns1) (lp2, ns2)++instance NFData QName where+ rnf x = seq x ()+ instance WNFData QName instance Show QName where- show = showQN+ show = showQN -- ----------------------------------------------------------------------------- @@ -501,9 +507,9 @@ -- the name and string cache -data NameCache = NC { _newXN :: ! Int -- next free name id- , _xnCache :: ! (M.Map String XName)- , _qnCache :: ! (M.Map (XName, XName, XName) QName) -- we need another type than QName+data NameCache = NC { _newXN :: !Int -- next free name id+ , _xnCache :: !(M.Map String XName)+ , _qnCache :: !(M.Map (XName, XName, XName) QName) -- we need another type than QName } -- for the key because of the unusable -- Eq instance of QName type ChangeNameCache r = NameCache -> (NameCache, r)@@ -524,8 +530,8 @@ , xmlNamespaceXName , xmlXName :: XName -initialXNames@- [ nullXName+initialXNames@[+ nullXName , xmlnsNamespaceXName , xmlnsXName , xmlNamespaceXName@@ -542,8 +548,7 @@ xmlnsQN :: QName -initialQNames@- [xmlnsQN] = [QN xmlnsXName nullXName xmlnsNamespaceXName]+initialQNames@[xmlnsQN] = [QN xmlnsXName nullXName xmlnsNamespaceXName] initialCache :: NameCache initialCache = NC@@ -556,12 +561,12 @@ changeNameCache :: NFData r => ChangeNameCache r -> r changeNameCache action = unsafePerformIO changeNameCache' where- action' c = - let r = action c - in + action' c =+ let r = action c+ in fst r `seq` r -- eval name cache to whnf- - changeNameCache' = ++ changeNameCache' = do -- putStrLn "modify cache" res <- atomicModifyIORef theNameCache action'
src/Text/XML/HXT/DOM/ShowXml.hs view
@@ -23,17 +23,16 @@ ) where -import Prelude hiding (showChar, showString)+import Prelude hiding (showChar, showString) -import Data.Maybe-import Data.Tree.Class-import Data.Tree.NTree.TypeDefs+import Data.Maybe+import Data.Tree.Class+import Data.Tree.NTree.TypeDefs -import Text.XML.HXT.DOM.TypeDefs -- XML Tree types-import Text.XML.HXT.DOM.XmlKeywords-import Text.XML.HXT.DOM.XmlNode ( mkDTDElem- , getDTDAttrl- )+import Text.XML.HXT.DOM.TypeDefs+import Text.XML.HXT.DOM.XmlKeywords+import Text.XML.HXT.DOM.XmlNode (getDTDAttrl, mkDTDElem)+import Text.Regex.XMLSchema.Generic(sed) -- ----------------------------------------------------------------------------- --@@ -63,12 +62,17 @@ -- a 2. quoting funtion for attribute values -- and an encoding function after tree conversion -xshow' :: (Char -> StringFct) -> (Char -> StringFct) -> (Char -> StringFct) -> XmlTrees -> Blob+xshow' :: (Char -> StringFct) ->+ (Char -> StringFct) ->+ (Char -> StringFct) ->+ XmlTrees -> Blob xshow' cquot aquot enc ts = stringToBlob $ (concatMap' enc (showTrees ts "")) "" where showTrees = showXmlTrees (concatMap' cquot) (concatMap' aquot) -xshow'' :: (Char -> StringFct) -> (Char -> StringFct) -> XmlTrees -> String+xshow'' :: (Char -> StringFct) ->+ (Char -> StringFct) ->+ XmlTrees -> String xshow'' cquot aquot ts = showTrees ts "" where showTrees = showXmlTrees (concatMap' cquot) (concatMap' aquot)@@ -79,37 +83,39 @@ -- ------------------------------------------------------------ -showXmlTrees :: (String -> StringFct) -> (String -> StringFct) -> XmlTrees -> StringFct+showXmlTrees :: (String -> StringFct) ->+ (String -> StringFct) ->+ XmlTrees -> StringFct showXmlTrees cf af = showTrees where -- ------------------------------------------------------------ - showTrees :: XmlTrees -> StringFct- showTrees = foldr (.) id . map showXmlTree+ showTrees :: XmlTrees -> StringFct+ showTrees = foldr (.) id . map showXmlTree {-# INLINE showTrees #-} - showTrees' :: XmlTrees -> StringFct- showTrees' = foldr (\ x y -> x . showNL . y) id . map showXmlTree+ showTrees' :: XmlTrees -> StringFct+ showTrees' = foldr (\ x y -> x . showNL . y) id . map showXmlTree {-# INLINE showTrees' #-} -- ------------------------------------------------------------ showXmlTree :: XmlTree -> StringFct showXmlTree (NTree (XText s) _) -- common cases first- = cf s+ = cf s showXmlTree (NTree (XTag t al) [])- = showLt . showQName t . showTrees al . showSlash . showGt+ = showLt . showQName t . showTrees al . showSlash . showGt showXmlTree (NTree (XTag t al) cs)- = showLt . showQName t . showTrees al . showGt+ = showLt . showQName t . showTrees al . showGt . showTrees cs . showLt . showSlash . showQName t . showGt showXmlTree (NTree (XAttr an) cs)- = showBlank+ = showBlank . showQName an . showEq . showQuot@@ -117,22 +123,25 @@ . showQuot showXmlTree (NTree (XBlob b) _)- = cf . blobToString $ b+ = cf . blobToString $ b showXmlTree (NTree (XCharRef i) _)- = showString "&#" . showString (show i) . showChar ';'+ = showString "&#" . showString (show i) . showChar ';' showXmlTree (NTree (XEntityRef r) _)- = showString "&" . showString r . showChar ';'+ = showString "&" . showString r . showChar ';' showXmlTree (NTree (XCmt c) _)- = showString "<!--" . showString c . showString "-->"+ = showString "<!--" . showString c . showString "-->" showXmlTree (NTree (XCdata d) _)- = showString "<![CDATA[" . showString d . showString "]]>"+ = showString "<![CDATA[" . showString d' . showString "]]>"+ where+ -- quote "]]>" in CDATA contents+ d' = sed (const "]]>") "\\]\\]>" d showXmlTree (NTree (XPi n al) _)- = showString "<?"+ = showString "<?" . showQName n . (foldr (.) id . map showPiAttr) al . showString "?>"@@ -140,17 +149,20 @@ showPiAttr :: XmlTree -> StringFct showPiAttr a@(NTree (XAttr an) cs) | qualifiedName an == a_value- = showBlank . showTrees cs+ -- <?some-pi ... ?>+ -- no XML quoting of PI value+ = showBlank . showXmlTrees showString showString cs | otherwise+ -- <?xml version="..." ... ?> = showXmlTree a showPiAttr a = showXmlTree a -- id showXmlTree (NTree (XDTD de al) cs)- = showXmlDTD de al cs+ = showXmlDTD de al cs showXmlTree (NTree (XError l e) _)- = showString "<!-- ERROR ("+ = showString "<!-- ERROR (" . shows l . showString "):\n" . showString e@@ -160,7 +172,7 @@ showXmlDTD :: DTDElem -> Attributes -> XmlTrees -> StringFct - showXmlDTD DOCTYPE al cs = showString "<!DOCTYPE "+ showXmlDTD DOCTYPE al cs = showString "<!DOCTYPE " . showAttr a_name al . showExternalId al . showInternalDTD cs@@ -171,7 +183,7 @@ . showTrees' ds . showChar ']' - showXmlDTD ELEMENT al cs = showString "<!ELEMENT "+ showXmlDTD ELEMENT al cs = showString "<!ELEMENT " . showAttr a_name al . showBlank . showElemType (lookup1 a_type al) cs@@ -233,19 +245,19 @@ . showString k showXmlDTD NOTATION al _cs- = showString "<!NOTATION "+ = showString "<!NOTATION " . showAttr a_name al . showExternalId al . showString " >" - showXmlDTD PENTITY al cs = showEntity "% " al cs+ showXmlDTD PENTITY al cs = showEntity "% " al cs showXmlDTD ENTITY al cs = showEntity "" al cs showXmlDTD PEREF al _cs = showPEAttr al showXmlDTD CONDSECT _ (c1 : cs)- = showString "<![ "+ = showString "<![ " . showXmlTree c1 . showString " [\n" . showTrees cs@@ -263,8 +275,8 @@ -- ------------------------------------------------------------ - showEntity :: String -> Attributes -> XmlTrees -> StringFct- showEntity kind al cs = showString "<!ENTITY "+ showEntity :: String -> Attributes -> XmlTrees -> StringFct+ showEntity kind al cs = showString "<!ENTITY " . showString kind . showAttr a_name al . showExternalId al@@ -273,8 +285,8 @@ . showString " >" - showEntityValue :: XmlTrees -> StringFct- showEntityValue [] = id+ showEntityValue :: XmlTrees -> StringFct+ showEntityValue [] = id showEntityValue cs = showBlank . showQuot . af (xshow cs)@@ -282,11 +294,11 @@ -- ------------------------------------------------------------ - showContent :: XmlTree -> StringFct+ showContent :: XmlTree -> StringFct showContent (NTree (XDTD de al) cs)- = cont2String de+ = cont2String de where- cont2String :: DTDElem -> StringFct+ cont2String :: DTDElem -> StringFct cont2String NAME = showAttr a_name al cont2String PEREF = showPEAttr al cont2String CONTENT = showLpar@@ -303,11 +315,11 @@ ) . s2 - showContent n = showXmlTree n+ showContent n = showXmlTree n -- ------------------------------------------------------------ - showElemType :: String -> XmlTrees -> StringFct+ showElemType :: String -> XmlTrees -> StringFct showElemType t cs | t == v_pcdata = showLpar . showString v_pcdata . showRpar | t == v_mixed@@ -320,7 +332,7 @@ . showRpar . showAttr a_modifier al1 | t == v_mixed -- incorrect tree, e.g. after erronius pe substitution- = showLpar+ = showLpar . showRpar | t == v_children &&@@ -333,54 +345,54 @@ where [(NTree (XDTD CONTENT al1) cs1)] = cs - mixedContent :: Attributes -> StringFct+ mixedContent :: Attributes -> StringFct mixedContent l = showString " | " . showAttr a_name l . showPEAttr l - selAttrl (XDTD _ as) = as+ selAttrl (XDTD _ as) = as selAttrl (XText tex) = [(a_name, tex)] selAttrl _ = [] -- ------------------------------------------------------------ -showQName :: QName -> StringFct-showQName = qualifiedName'+showQName :: QName -> StringFct+showQName = qualifiedName' {-# INLINE showQName #-} -- ------------------------------------------------------------ -showQuoteString :: String -> StringFct-showQuoteString s = showQuot . showString s . showQuot+showQuoteString :: String -> StringFct+showQuoteString s = showQuot . showString s . showQuot -- ------------------------------------------------------------ -showAttr :: String -> Attributes -> StringFct-showAttr k al = showString (fromMaybe "" . lookup k $ al)+showAttr :: String -> Attributes -> StringFct+showAttr k al = showString (fromMaybe "" . lookup k $ al) -- ------------------------------------------------------------ -showPEAttr :: Attributes -> StringFct-showPEAttr al = showPE (lookup a_peref al)+showPEAttr :: Attributes -> StringFct+showPEAttr al = showPE (lookup a_peref al) where- showPE (Just pe) = showChar '%'+ showPE (Just pe) = showChar '%' . showString pe . showChar ';'- showPE Nothing = id+ showPE Nothing = id -- ------------------------------------------------------------ -showExternalId :: Attributes -> StringFct-showExternalId al = id2Str (lookup k_system al) (lookup k_public al)+showExternalId :: Attributes -> StringFct+showExternalId al = id2Str (lookup k_system al) (lookup k_public al) where- id2Str Nothing Nothing = id- id2Str (Just s) Nothing = showBlank+ id2Str Nothing Nothing = id+ id2Str (Just s) Nothing = showBlank . showString k_system . showBlank . showQuoteString s- id2Str Nothing (Just p) = showBlank+ id2Str Nothing (Just p) = showBlank . showString k_public . showBlank . showQuoteString p- id2Str (Just s) (Just p) = showBlank+ id2Str (Just s) (Just p) = showBlank . showString k_public . showBlank . showQuoteString p@@ -389,11 +401,11 @@ -- ------------------------------------------------------------ -showNData :: Attributes -> StringFct-showNData al = nd2Str (lookup k_ndata al)+showNData :: Attributes -> StringFct+showNData al = nd2Str (lookup k_ndata al) where- nd2Str Nothing = id- nd2Str (Just v) = showBlank+ nd2Str Nothing = id+ nd2Str (Just v) = showBlank . showString k_ndata . showBlank . showString v@@ -430,7 +442,7 @@ showNL = showChar '\n' {-# INLINE showNL #-} -showChar :: Char -> StringFct+showChar :: Char -> StringFct showChar = (:) {-# INLINE showChar #-} @@ -443,4 +455,3 @@ {-# INLINE concatMap' #-} -- ------------------------------------------------------------------------------
src/Text/XML/HXT/DOM/TypeDefs.hs view
@@ -31,8 +31,8 @@ import Data.AssocList import Data.Binary-import qualified Data.ByteString.Lazy as BS-import qualified Data.ByteString.Lazy.Char8 as CS+import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as CS import Data.Tree.NTree.TypeDefs import Data.Tree.NTree.Zipper.TypeDefs@@ -75,7 +75,7 @@ | XCdata String -- ^ CDATA section (leaf) | XPi QName XmlTrees -- ^ Processing Instr with qualified name (leaf) -- with list of attributes.- -- If tag name is xml, attributs are \"version\", \"encoding\", \"standalone\",+ -- If tag name is xml, attributes are \"version\", \"encoding\", \"standalone\", -- else attribute list is empty, content is a text child node | XTag QName XmlTrees -- ^ tag with qualified name and list of attributes (inner node or leaf) | XDTD DTDElem Attributes -- ^ DTD element with assoc list for dtd element features@@ -126,7 +126,7 @@ put (XPi qn ts) = put ( 5::Word8) >> put qn >> put ts put (XDTD de al) = put ( 7::Word8) >> put de >> put al put (XError n e) = put ( 9::Word8) >> put n >> put e- put (XBlob b) = put (10::Word8) >> put b + put (XBlob b) = put (10::Word8) >> put b get = do tag <- getWord8@@ -194,13 +194,14 @@ deriving (Eq, Ord, Enum, Show, Read, Typeable) instance NFData DTDElem+ where rnf x = seq x ()+ instance WNFData DTDElem instance Binary DTDElem where- put de = put ((toEnum . fromEnum $ de)::Word8) -- DTDElem is not yet instance of Enum- get = do- tag <- getWord8- return $! (toEnum . fromEnum $ tag)+ put de = put ((toEnum . fromEnum $ de)::Word8) -- DTDElem is not yet instance of Enum+ get = do tag <- getWord8+ return $! (toEnum . fromEnum $ tag) -- ----------------------------------------------------------------------------- @@ -252,9 +253,9 @@ -- such that the selected nodes can be processed or selected later in -- processing a document tree -data XmlNodeSet = XNS { thisNode :: Bool -- ^ is this node part of the set ?- , attrNodes :: [QName] -- ^ the set of attribute nodes- , childNodes :: ChildNodes -- ^ the set of child nodes, a list of pairs of index and node set+data XmlNodeSet = XNS { thisNode :: Bool -- ^ is this node part of the set ?+ , attrNodes :: [QName] -- ^ the set of attribute nodes+ , childNodes :: ChildNodes -- ^ the set of child nodes, a list of pairs of index and node set } deriving (Eq, Show, Typeable)
src/Text/XML/HXT/DTDValidation/DTDValidation.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE FlexibleContexts #-}+ -- ------------------------------------------------------------ {- |@@ -36,8 +38,8 @@ ) where -import Text.XML.HXT.DTDValidation.TypeDefs-import Text.XML.HXT.DTDValidation.AttributeValueValidation+import Text.XML.HXT.DTDValidation.AttributeValueValidation+import Text.XML.HXT.DTDValidation.TypeDefs -- | -- Validate a DTD.
src/Text/XML/HXT/DTDValidation/RE.hs view
@@ -48,6 +48,8 @@ ) where +import Data.List (foldl')+ -- | -- Data type for regular expressions. @@ -61,7 +63,7 @@ | RE_OPT (RE a) --' L(e?) = L(e) `union` { [] } | RE_SEQ (RE a) (RE a) --' L(e,f) = { x ++ y | x <- L(e), y <- L(f) } | RE_ALT (RE a) (RE a) --' L(e|f) = L(e) `union` L(f)- deriving (Show, Eq)+ deriving (Show, Eq, Ord) @@ -128,10 +130,11 @@ -- but without this simplification the runtime can increase exponentally -- when computing deltas, e.g. for a** or (a|b*)* which is the same as (a|b)* -rem_rep :: RE a -> RE a-rem_rep (RE_ALT e1 e2) = RE_ALT (rem_rep e1) (rem_rep e2)-rem_rep (RE_REP e1) = rem_rep e1-rem_rep e1 = e1+rem_rep :: RE a -> RE a+rem_rep (RE_ALT RE_UNIT e2) = e2+rem_rep (RE_ALT e1 e2) = RE_ALT (rem_rep e1) (rem_rep e2)+rem_rep (RE_REP e1) = rem_rep e1+rem_rep e1 = e1 -- |@@ -144,7 +147,9 @@ re_plus :: RE a -> RE a re_plus RE_UNIT = RE_UNIT re_plus (RE_ZERO m) = RE_ZERO m-re_plus e = RE_PLUS e+re_plus e+ | nullable e = re_rep e -- nullable e => e+ == e*+ | otherwise = re_seq e (re_rep e) -- |@@ -154,11 +159,10 @@ -- -- - returns : new regular expression -re_opt :: RE a -> RE a+re_opt :: (Ord a) => RE a -> RE a re_opt RE_UNIT = RE_UNIT re_opt (RE_ZERO _) = RE_UNIT-re_opt e = RE_OPT e-+re_opt e = re_alt RE_UNIT e -- | -- Constructs a sequence (,) of two regular expressions@@ -169,12 +173,13 @@ -- -- - returns : new regular expression -re_seq :: RE a -> RE a -> RE a-re_seq (RE_ZERO m) _ = RE_ZERO m-re_seq RE_UNIT f = f-re_seq _ (RE_ZERO m) = RE_ZERO m-re_seq e RE_UNIT = e-re_seq e f = RE_SEQ e f+re_seq :: RE a -> RE a -> RE a+re_seq e1@(RE_ZERO _) _ = e1 -- simplification+re_seq RE_UNIT e2 = e2 -- simplification+re_seq _ e2@(RE_ZERO _) = e2 -- simplification+re_seq e1 RE_UNIT = e1 -- simplification+re_seq (RE_SEQ e11 e12) e2 = re_seq e11 (re_seq e12 e2) -- right assoc.+re_seq e1 e2 = RE_SEQ e1 e2 -- |@@ -186,10 +191,18 @@ -- -- - returns : new regular expression -re_alt :: RE a -> RE a -> RE a-re_alt (RE_ZERO _) f = f-re_alt e (RE_ZERO _) = e-re_alt e f = RE_ALT e f+re_alt :: (Ord a) => RE a -> RE a -> RE a+re_alt (RE_ZERO _) e2 = e2+re_alt e1 (RE_ZERO _) = e1+re_alt (RE_ALT e11 e12) e2 = re_alt e11 (re_alt e12 e2) -- is right assoc+re_alt e1 e2@(RE_ALT e21 e22)+ | e1 == e21 = e2 -- duplicates removed, the effective rule+ | e1 > e21 = re_alt e21 (re_alt e1 e22) -- sort alternatives+ | otherwise = RE_ALT e1 e2+re_alt e1 e2+ | e1 == e2 = e2 -- simplification, the effective rule+ | e1 > e2 = re_alt e2 e1 -- sort alts for unique repr.+ | otherwise = RE_ALT e1 e2 @@ -208,7 +221,7 @@ -- - returns : true if regular expression matches the empty sequence, -- otherwise false -nullable :: (Show a) => RE a -> Bool+nullable :: RE a -> Bool nullable (RE_ZERO _) = False nullable RE_UNIT = True nullable (RE_SYM _) = False@@ -231,7 +244,7 @@ -- -- - returns : the derived regular expression -delta :: (Eq a, Show a) => RE a -> a -> RE a+delta :: (Ord a, Show a) => RE a -> a -> RE a delta re x = case re of RE_ZERO _ -> re -- re_zero m RE_UNIT -> re_zero ("Symbol " ++ show x ++ " unexpected.")@@ -257,8 +270,8 @@ -- -- - returns : the derived regular expression -matches :: (Eq a, Show a) => RE a -> [a] -> RE a-matches e = foldl delta e+matches :: (Ord a, Show a) => RE a -> [a] -> RE a+matches e = foldl' delta e -- |@@ -273,7 +286,7 @@ -- - returns : empty String if input matched the regular expression, otherwise -- an error message is returned -checkRE :: (Show a) => RE a -> String+checkRE :: (Eq a, Show a) => RE a -> String checkRE (RE_UNIT) = "" checkRE (RE_ZERO m) = m checkRE re@@ -293,11 +306,11 @@ -- -- - returns : the string representation of the regular expression -printRE :: (Show a) => RE a -> String+printRE :: (Eq a, Show a) => RE a -> String printRE re' = "( " ++ printRE1 re' ++ " )" where- printRE1 :: (Show a) => RE a -> String+ -- printRE1 :: (Eq a, Show a) => RE a -> String printRE1 re = case re of RE_ZERO m -> "ERROR: " ++ m RE_UNIT -> ""@@ -312,11 +325,16 @@ RE_OPT e | isSingle e -> printRE1 e ++ "?" | otherwise -> "(" ++ printRE1 e ++ ")?"+ RE_SEQ e1 (RE_REP e2)+ | e1 == e2 -> printRE1 (RE_PLUS e1)+ RE_SEQ e1 (RE_SEQ (RE_REP e2) e3)+ | e1 == e2 -> printRE1 (RE_SEQ (RE_PLUS e1) e3) RE_SEQ e f | isAlt e && not (isAlt f) -> "(" ++ printRE1 e ++ ") , " ++ printRE1 f | not (isAlt e) && isAlt f -> printRE1 e ++ " , (" ++ printRE1 f ++ ")" | isAlt e && isAlt f -> "(" ++ printRE1 e ++ ") , (" ++ printRE1 f ++ ")" | otherwise -> printRE1 e ++ " , " ++ printRE1 f+ RE_ALT RE_UNIT f -> printRE1 (RE_OPT f) RE_ALT e f | isSeq e && not (isSeq f) -> "(" ++ printRE1 e ++ ") | " ++ printRE1 f | not (isSeq e) && isSeq f -> printRE1 e ++ " | (" ++ printRE1 f ++ ")"@@ -331,11 +349,14 @@ isSingle _ = False - isSeq :: RE a -> Bool+ isSeq :: (Eq a) => RE a -> Bool+ isSeq (RE_SEQ e1 (RE_REP e2))+ | e1 == e2 = False -- is transformed back into RE_PLUS isSeq (RE_SEQ _ _) = True isSeq _ = False isAlt :: RE a -> Bool+ isAlt (RE_ALT RE_UNIT _)= False -- is transformed back into a RE_OPT isAlt (RE_ALT _ _) = True isAlt _ = False
src/Text/XML/HXT/DTDValidation/Validation.hs view
@@ -36,12 +36,12 @@ where -import Text.XML.HXT.DTDValidation.TypeDefs+import Text.XML.HXT.DTDValidation.TypeDefs -import qualified Text.XML.HXT.DTDValidation.DTDValidation as DTDValidation+import qualified Text.XML.HXT.DTDValidation.DocTransformation as DocTransformation import qualified Text.XML.HXT.DTDValidation.DocValidation as DocValidation+import qualified Text.XML.HXT.DTDValidation.DTDValidation as DTDValidation import qualified Text.XML.HXT.DTDValidation.IdValidation as IdValidation-import qualified Text.XML.HXT.DTDValidation.DocTransformation as DocTransformation -- | -- Main validation filter. Check if the DTD and the document are valid.@@ -127,8 +127,8 @@ >>> ( filterA $ isDTDDoctype >>> getDTDAttrl >>> isA (hasEntry a_name) ) -generalEntitiesDefined :: XmlArrow-generalEntitiesDefined = getDTDSubset+generalEntitiesDefined :: XmlArrow+generalEntitiesDefined = getDTDSubset >>> deep isDTDEntity
src/Text/XML/HXT/DTDValidation/XmlRE.hs view
@@ -36,17 +36,17 @@ ) where --- import Debug.Trace(trace)+-- import Debug.Trace (trace) -import Text.XML.HXT.DTDValidation.RE hiding (matches)+import Data.List (foldl') -import Text.XML.HXT.DTDValidation.TypeDefs-import Text.XML.HXT.Arrow.Edit- ( removeComment- , removeWhiteSpace- )-import qualified Text.XML.HXT.DOM.XmlNode as XN+import Text.XML.HXT.DTDValidation.RE hiding (matches) +import Text.XML.HXT.Arrow.Edit (removeComment,+ removeWhiteSpace)+import qualified Text.XML.HXT.DOM.XmlNode as XN+import Text.XML.HXT.DTDValidation.TypeDefs+ -- | -- Derives a regular expression with respect to a list of elements. --@@ -58,7 +58,7 @@ matches :: RE String -> XmlTrees -> RE String matches re list- = foldl delta re (removeUnimportantStuff $$ list)+ = foldl' delta re (removeUnimportantStuff $$ list) where removeUnimportantStuff :: XmlArrow removeUnimportantStuff = processBottomUp (removeWhiteSpace >>> removeComment)
src/Text/XML/HXT/IO/GetFILE.hs view
@@ -22,18 +22,17 @@ where -import qualified Data.ByteString.Lazy as B+import Control.Exception ( try ) +import qualified Data.ByteString.Lazy as B+ import Network.URI ( unEscapeString )- import System.IO.Error ( ioeGetErrorString- , try )- import System.Directory ( doesFileExist- , getPermissions- , readable+ -- , getPermissions+ -- , readable ) import Text.XML.HXT.DOM.XmlKeywords @@ -67,8 +66,9 @@ case source'' of Nothing -> return $ fileErr "file not found" Just fn -> do- perm <- getPermissions fn- if not (readable perm)+ -- perm <- getPermissions fn -- getPermission may fail+ -- if not (readable perm)+ if False then return $ fileErr "file not readable" else do c <- try $
src/Text/XML/HXT/Parser/HtmlParsec.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ -- ------------------------------------------------------------ {- |@@ -33,7 +35,10 @@ where -import Control.Applicative ( (<$>) )+#if MIN_VERSION_base(4,8,2)+#else+import Control.Applicative ((<$>))+#endif import Data.Char ( toLower , toUpper@@ -119,7 +124,7 @@ parseHtmlDocument = parseHtmlFromString htmlDocument parseHtmlContent :: String -> XmlTrees-parseHtmlContent = parseHtmlFromString htmlContent "text"+parseHtmlContent = parseHtmlFromString htmlContent "string" -- ------------------------------------------------------------
src/Text/XML/HXT/Parser/XmlCharParser.hs view
@@ -32,34 +32,32 @@ ) where -import Data.Char.Properties.XMLCharProps ( isXmlCharCR- , isXmlNameChar- , isXmlNameStartChar- , isXmlNCNameChar- , isXmlNCNameStartChar- , isXmlLetter- , isXmlSpaceCharCR- )+import Data.Char.Properties.XMLCharProps (isXmlCharCR, isXmlLetter,+ isXmlNCNameChar,+ isXmlNCNameStartChar,+ isXmlNameChar,+ isXmlNameStartChar,+ isXmlSpaceCharCR) -import Data.String.Unicode+import Data.String.Unicode -import Text.ParserCombinators.Parsec+import Text.ParserCombinators.Parsec -- ------------------------------------------------------------ -type XParser s a = GenParser Char (XPState s) a+type XParser s a = GenParser Char (XPState s) a type SimpleXParser a = XParser () a -data XPState s = XPState- { xps_normalizeNewline :: ! Bool- , xps_userState :: s+data XPState s = XPState+ { xps_normalizeNewline :: !Bool+ , xps_userState :: s } -withNormNewline :: a -> XPState a-withNormNewline x = XPState True x+withNormNewline :: a -> XPState a+withNormNewline x = XPState True x -withoutNormNewline :: a -> XPState a-withoutNormNewline x = XPState False x+withoutNormNewline :: a -> XPState a+withoutNormNewline x = XPState False x -- ------------------------------------------------------------ --@@ -142,4 +140,3 @@ <?> "newline" -- -------------------------------------------------------------
src/Text/XML/HXT/Parser/XmlParsec.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ -- ------------------------------------------------------------ {- |@@ -37,6 +39,7 @@ , textDecl , encodingDecl , xread+ , xreadDoc , parseXmlContent , parseXmlDocEncodingSpec@@ -57,60 +60,42 @@ ) where -import Control.Applicative ( (<$>) )+#if MIN_VERSION_base(4,8,2)+#else+import Control.Applicative ((<$>))+#endif -import Text.ParserCombinators.Parsec ( runParser- , (<?>), (<|>)- , char- , string- , eof- , between- , many- , many1- , notFollowedBy- , option- , try- , unexpected- , getPosition- , getInput- , sourceName- )+import Text.ParserCombinators.Parsec (between, char, eof,+ getInput, getPosition,+ many, many1,+ notFollowedBy, option,+ runParser, sourceName,+ string, try, unexpected,+ (<?>), (<|>)) -import Text.XML.HXT.DOM.ShowXml ( xshow- )-import Text.XML.HXT.DOM.Interface-import Text.XML.HXT.DOM.XmlNode ( mkElement'- , mkAttr'- , mkRoot'- , mkDTDElem'- , mkText'- , mkCmt'- , mkCdata'- , mkError'- , mkPi'- , isText- , isRoot- , getText- , getChildren- , getAttrl- , getAttrName- , changeAttrl- , mergeAttrl- )-import Text.XML.HXT.Parser.XmlCharParser ( xmlChar- , XParser- , SimpleXParser- , XPState- , withNormNewline- , withoutNormNewline- )-import qualified Text.XML.HXT.Parser.XmlTokenParser as XT-import qualified Text.XML.HXT.Parser.XmlDTDTokenParser as XD+import Text.XML.HXT.DOM.Interface+import Text.XML.HXT.DOM.ShowXml (xshow)+import Text.XML.HXT.DOM.XmlNode (changeAttrl,+ getAttrName, getAttrl,+ getChildren, getText,+ isRoot, isText,+ mergeAttrl, mkAttr',+ mkCdata', mkCmt',+ mkDTDElem', mkElement',+ mkError', mkPi',+ mkRoot', mkText')+import Text.XML.HXT.Parser.XmlCharParser (SimpleXParser, XPState,+ XParser,+ withNormNewline,+ withoutNormNewline,+ xmlChar)+import qualified Text.XML.HXT.Parser.XmlDTDTokenParser as XD+import qualified Text.XML.HXT.Parser.XmlTokenParser as XT -import Control.FlatSeq+import Control.FlatSeq -import Data.Char (toLower)-import Data.Maybe+import Data.Char (toLower)+import Data.Maybe -- import Debug.Trace @@ -192,7 +177,7 @@ -- the leading <! is already parsed, no try neccessary cDSect' :: XParser s XmlTree-cDSect' +cDSect' = cDSect'' (string "[CDATA[" >> return ()) cDSect'' :: XParser s () -> XParser s XmlTree@@ -466,14 +451,14 @@ content = XT.mergeTextNodes <$> many- ( ( do -- parse markup but no closing tags+ ( ( do -- parse markup but no closing tags try ( XT.lt >> notFollowedBy (char '/') >> return () )- markup+ markup ) <|> charData'@@ -482,17 +467,17 @@ ) where markup- = element'- <|>- pI'- <|>- ( char '!'+ = element'+ <|>+ pI'+ <|>+ ( char '!' >>- ( comment'- <|>- cDSect'+ ( comment'+ <|>+ cDSect' )- )+ ) contentWithTextDecl :: XParser s XmlTrees contentWithTextDecl@@ -618,13 +603,19 @@ -- see also: 'parseXmlContent' xread :: String -> XmlTrees-xread str+xread = xread' content -- take the content parser for parsing the string++xreadDoc :: String -> XmlTrees+xreadDoc = xread' document' -- take the document' parser for parsing the string++xread' :: XParser () XmlTrees -> String -> XmlTrees+xread' content' str = parseXmlFromString parser (withNormNewline ()) loc str where loc = "string: " ++ show (if length str > 40 then take 40 str ++ "..." else str) parser = do- res <- content -- take the content parser for parsing the string- eof -- and test on everything consumed+ res <- content'+ eof -- test on everything consumed return res -- |
src/Text/XML/HXT/Parser/XmlTokenParser.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ -- ------------------------------------------------------------ {- |@@ -83,8 +85,12 @@ ) where -import Control.Applicative ( (<$>) )+#if MIN_VERSION_base(4,8,2)+#else+import Control.Applicative ((<$>))+#endif + import Data.Char.Properties.XMLCharProps ( isXmlChar , isXmlCharCR )@@ -591,7 +597,7 @@ mergeTextNodes :: XmlTrees -> XmlTrees mergeTextNodes = foldr addText []- where + where addText :: XmlTree -> XmlTrees -> XmlTrees addText t [] = [t]@@ -599,5 +605,3 @@ = mergeText t t1 ++ ts -- --------------------------------------------------------------
src/Text/XML/HXT/Version.hs view
@@ -1,4 +1,4 @@ module Text.XML.HXT.Version where hxt_version :: String-hxt_version = "9.1.0"+hxt_version = "9.3.1.15"
src/Text/XML/HXT/XMLSchema/DataTypeLibW3CNames.hs view
@@ -26,7 +26,6 @@ w3cNS :: String w3cNS = "http://www.w3.org/2001/XMLSchema-datatypes" - xsd_string , xsd_normalizedString , xsd_token@@ -58,8 +57,21 @@ , xsd_unsignedLong , xsd_unsignedInt , xsd_unsignedShort- , xsd_unsignedByte :: String+ , xsd_unsignedByte + , xsd_boolean+ , xsd_float+ , xsd_double+ , xsd_time+ , xsd_duration+ , xsd_date+ , xsd_dateTime+ , xsd_gDay+ , xsd_gMonth+ , xsd_gMonthDay+ , xsd_gYear+ , xsd_gYearMonth :: String+ xsd_string = "string" xsd_normalizedString = "normalizedString" xsd_token = "token"@@ -93,6 +105,18 @@ xsd_unsignedShort = "unsignedShort" xsd_unsignedByte = "unsignedByte" +xsd_boolean = "boolean"+xsd_float = "float"+xsd_double = "double"+xsd_time = "time"+xsd_duration = "duration"+xsd_date = "date"+xsd_dateTime = "dateTime"+xsd_gDay = "gDay"+xsd_gMonth = "gMonth"+xsd_gMonthDay = "gMonthDay"+xsd_gYear = "gYear"+xsd_gYearMonth = "gYearMonth" xsd_length , xsd_maxLength@@ -104,7 +128,8 @@ , xsd_totalDigits , xsd_fractionDigits , xsd_pattern- , xsd_enumeration :: String+ , xsd_enumeration+ , xsd_whiteSpace :: String xsd_length = "length" xsd_maxLength = "maxLength"@@ -120,5 +145,7 @@ xsd_pattern = "pattern" xsd_enumeration = "enumeration"++xsd_whiteSpace = "whiteSpace" -- ----------------------------------------