hxthelper (empty) → 0.2.2
raw patch · 4 files changed
+567/−0 lines, 4 filesdep +basedep +bytestringdep +encodingbuild-type:Customsetup-changed
Dependencies added: base, bytestring, encoding, hxt, mtl
Files
- LICENSE +165/−0
- Setup.hs +16/−0
- hxthelper.cabal +20/−0
- src/Text/XML/HXT/Helper.hs +366/−0
+ LICENSE view
@@ -0,0 +1,165 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.+++ This version of the GNU Lesser General Public License incorporates+the terms and conditions of version 3 of the GNU General Public+License, supplemented by the additional permissions listed below.++ 0. Additional Definitions.++ As used herein, "this License" refers to version 3 of the GNU Lesser+General Public License, and the "GNU GPL" refers to version 3 of the GNU+General Public License.++ "The Library" refers to a covered work governed by this License,+other than an Application or a Combined Work as defined below.++ An "Application" is any work that makes use of an interface provided+by the Library, but which is not otherwise based on the Library.+Defining a subclass of a class defined by the Library is deemed a mode+of using an interface provided by the Library.++ A "Combined Work" is a work produced by combining or linking an+Application with the Library. The particular version of the Library+with which the Combined Work was made is also called the "Linked+Version".++ The "Minimal Corresponding Source" for a Combined Work means the+Corresponding Source for the Combined Work, excluding any source code+for portions of the Combined Work that, considered in isolation, are+based on the Application, and not on the Linked Version.++ The "Corresponding Application Code" for a Combined Work means the+object code and/or source code for the Application, including any data+and utility programs needed for reproducing the Combined Work from the+Application, but excluding the System Libraries of the Combined Work.++ 1. Exception to Section 3 of the GNU GPL.++ You may convey a covered work under sections 3 and 4 of this License+without being bound by section 3 of the GNU GPL.++ 2. Conveying Modified Versions.++ If you modify a copy of the Library, and, in your modifications, a+facility refers to a function or data to be supplied by an Application+that uses the facility (other than as an argument passed when the+facility is invoked), then you may convey a copy of the modified+version:++ a) under this License, provided that you make a good faith effort to+ ensure that, in the event an Application does not supply the+ function or data, the facility still operates, and performs+ whatever part of its purpose remains meaningful, or++ b) under the GNU GPL, with none of the additional permissions of+ this License applicable to that copy.++ 3. Object Code Incorporating Material from Library Header Files.++ The object code form of an Application may incorporate material from+a header file that is part of the Library. You may convey such object+code under terms of your choice, provided that, if the incorporated+material is not limited to numerical parameters, data structure+layouts and accessors, or small macros, inline functions and templates+(ten or fewer lines in length), you do both of the following:++ a) Give prominent notice with each copy of the object code that the+ Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the object code with a copy of the GNU GPL and this license+ document.++ 4. Combined Works.++ You may convey a Combined Work under terms of your choice that,+taken together, effectively do not restrict modification of the+portions of the Library contained in the Combined Work and reverse+engineering for debugging such modifications, if you also do each of+the following:++ a) Give prominent notice with each copy of the Combined Work that+ the Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the Combined Work with a copy of the GNU GPL and this license+ document.++ c) For a Combined Work that displays copyright notices during+ execution, include the copyright notice for the Library among+ these notices, as well as a reference directing the user to the+ copies of the GNU GPL and this license document.++ d) Do one of the following:++ 0) Convey the Minimal Corresponding Source under the terms of this+ License, and the Corresponding Application Code in a form+ suitable for, and under terms that permit, the user to+ recombine or relink the Application with a modified version of+ the Linked Version to produce a modified Combined Work, in the+ manner specified by section 6 of the GNU GPL for conveying+ Corresponding Source.++ 1) Use a suitable shared library mechanism for linking with the+ Library. A suitable mechanism is one that (a) uses at run time+ a copy of the Library already present on the user's computer+ system, and (b) will operate properly with a modified version+ of the Library that is interface-compatible with the Linked+ Version.++ e) Provide Installation Information, but only if you would otherwise+ be required to provide such information under section 6 of the+ GNU GPL, and only to the extent that such information is+ necessary to install and execute a modified version of the+ Combined Work produced by recombining or relinking the+ Application with a modified version of the Linked Version. (If+ you use option 4d0, the Installation Information must accompany+ the Minimal Corresponding Source and Corresponding Application+ Code. If you use option 4d1, you must provide the Installation+ Information in the manner specified by section 6 of the GNU GPL+ for conveying Corresponding Source.)++ 5. Combined Libraries.++ You may place library facilities that are a work based on the+Library side by side in a single library together with other library+facilities that are not Applications and are not covered by this+License, and convey such a combined library under terms of your+choice, if you do both of the following:++ a) Accompany the combined library with a copy of the same work based+ on the Library, uncombined with any other library facilities,+ conveyed under the terms of this License.++ b) Give prominent notice with the combined library that part of it+ is a work based on the Library, and explaining where to find the+ accompanying uncombined form of the same work.++ 6. Revised Versions of the GNU Lesser General Public License.++ The Free Software Foundation may publish revised and/or new versions+of the GNU Lesser General Public License from time to time. Such new+versions will be similar in spirit to the present version, but may+differ in detail to address new problems or concerns.++ Each version is given a distinguishing version number. If the+Library as you received it specifies that a certain numbered version+of the GNU Lesser General Public License "or any later version"+applies to it, you have the option of following the terms and+conditions either of that published version or of any later version+published by the Free Software Foundation. If the Library as you+received it does not specify a version number of the GNU Lesser+General Public License, you may choose any version of the GNU Lesser+General Public License ever published by the Free Software Foundation.++ If the Library as you received it specifies that a proxy can decide+whether future versions of the GNU Lesser General Public License shall+apply, that proxy's public statement of acceptance of any version is+permanent authorization for you to choose that version for the+Library.
+ Setup.hs view
@@ -0,0 +1,16 @@+import Distribution.Simple+import Distribution.Simple.Setup+import Distribution.PackageDescription+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Utils++import System.Cmd+import System.FilePath++main :: IO ()+main = defaultMainWithHooks hooks+ where hooks = simpleUserHooks { runTests = runTests' }++runTests' :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO ()+runTests' _ _ _ lbi = system testprog >> return ()+ where testprog = "runhaskell -isrc test/HelperTests.hs"
+ hxthelper.cabal view
@@ -0,0 +1,20 @@+Name: hxthelper+Version: 0.2.2+Synopsis: Helper functions for HXT+License: LGPL+License-file: LICENSE+Author: David Leuschner, Stefan Wehr+Maintainer: David Leuschner <leuschner@openfactis.org>+Category: XML+Description: Helper functions for HXT including pure parsing and serialization+ functions, easier pickling of sum-types, ensuring all XML content+ is parsed during unpickling.+Build-Type: Custom+Cabal-Version: >= 1.6++Library+ Hs-Source-Dirs: src+ GHC-Options: -W -fno-warn-unused-imports -fno-warn-orphans+ -fno-warn-unused-binds -fno-warn-unused-matches+ Build-Depends: base >= 4 && < 5, hxt >= 8.3 && < 8.6, bytestring, mtl, encoding == 0.6.*+ Exposed-Modules: Text.XML.HXT.Helper
+ src/Text/XML/HXT/Helper.hs view
@@ -0,0 +1,366 @@+module Text.XML.HXT.Helper++-- == EXPORTS =================================================================+ (XmlValidator+ ,XmlEncoding, xmlEncodingFromString, xmlEncodingToString+ ,serializeXml, parseXml, ParseXmlConfig(..), defaultParseXmlConfig, xmlEncoding+ ,pickle, pickleWithEnc, pickleStr, unpickle, unpickleStr, unpickleDocM+ ,validateAndUnpickle+ ,PUCase, xpOne, xpMany, xpTagSwitch, xpCase, xpCaseConst, xpSwitch+ ,xpTextFixed, xpConsumeAll, xpExhaustiveList, xpIgnoreOnUnpickle, xpEither+ ,xpByteString+ ,_ISO8859_1_, _ISO8859_2_, _ISO8859_3_, _ISO8859_4_, _ISO8859_5_+ ,_ISO8859_6_, _ISO8859_7_, _ISO8859_8_, _ISO8859_9_, _ISO8859_10_+ ,_ISO8859_11_, _ISO8859_13_, _ISO8859_14_, _ISO8859_15_, _ISO8859_16_+ ,_USASCII_, _UCS2_, _UTF8_, _UTF16_, _UTF16BE_, _UTF16LE_, _ISOLATIN1_+ ,_UNICODE_)+where++-- == IMPORTS =================================================================++----------------------------------------+-- STDLIB+----------------------------------------+import Control.Monad.Error ()+import qualified Control.Monad as M+import Data.Char (toLower)+import Data.Maybe (fromMaybe)+import Data.List (elemIndex)++----------------------------------------+-- SITE-PACKAGES+----------------------------------------+import Control.Arrow.ArrowIf (when)+import Control.Arrow.ArrowList (this,none)+import Control.Arrow.ArrowTree (processChildren, processTopDown)++import Data.Tree.NTree.TypeDefs (NTree(..))++import Text.XML.HXT.Arrow+ ( XmlTree+ , runLA, constA, (>>>), arr+ , replaceChildren,xshow,mkText,escapeXmlDoc+ , getChildren)++import Text.XML.HXT.Arrow.Namespace (propagateNamespaces,uniqueNamespacesFromDeclAndQNames)+import Text.XML.HXT.Arrow.Pickle (PU(..), unpickleDoc,+ pickleDoc ,xpElem, xpList, xpAlt, xpWrap,+ xpWrapMaybe, xpText, xpText0)+import Text.XML.HXT.Arrow.Pickle.Schema (scFixed)+import Text.XML.HXT.Arrow.Pickle.Xml (St(..))+import Text.XML.HXT.Arrow.ParserInterface (parseXmlDoc,substXmlEntityRefs)+import Text.XML.HXT.Arrow.Edit (canonicalizeContents, removeDocWhiteSpace, removeAllComment+ ,indentDoc)+import Text.XML.HXT.Arrow.XmlArrow (ArrowXml, root, isPi, hasName)+import Text.XML.HXT.Arrow.DocumentOutput (encodeDocument')+import Text.XML.HXT.DOM.TypeDefs (XNode(..))+import Text.XML.HXT.DOM.XmlKeywords+ (t_xml+ ,iso8859_1, iso8859_2, iso8859_3, iso8859_4, iso8859_5, iso8859_6+ ,iso8859_7, iso8859_8, iso8859_9, iso8859_10, iso8859_11, iso8859_13+ ,iso8859_14, iso8859_15, iso8859_16, usAscii, ucs2, utf8, utf16, utf16be+ ,utf16le, unicodeString, isoLatin1)++import qualified Data.ByteString.Lazy.Char8 as BSLChar+import qualified Data.ByteString.Lazy as BSL+import Data.Encoding (DynEncoding, encodingFromStringExplicit, decodeLazyByteStringExplicit)++-- == TYPES ===================================================================++type XmlValidator = BSLChar.ByteString -> Either String ()++newtype XmlEncoding = XmlEncoding { xmlEncodingName :: String } deriving (Eq)++instance Show XmlEncoding where+ show (XmlEncoding name) = name++_UNICODE_ :: XmlEncoding+_UNICODE_ = XmlEncoding unicodeString++_ISO8859_1_ :: XmlEncoding+_ISO8859_1_ = XmlEncoding iso8859_1++_ISO8859_2_ :: XmlEncoding+_ISO8859_2_ = XmlEncoding iso8859_2++_ISO8859_3_ :: XmlEncoding+_ISO8859_3_ = XmlEncoding iso8859_3++_ISO8859_4_ :: XmlEncoding+_ISO8859_4_ = XmlEncoding iso8859_4++_ISO8859_5_ :: XmlEncoding+_ISO8859_5_ = XmlEncoding iso8859_5++_ISO8859_6_ :: XmlEncoding+_ISO8859_6_ = XmlEncoding iso8859_6++_ISO8859_7_ :: XmlEncoding+_ISO8859_7_ = XmlEncoding iso8859_7++_ISO8859_8_ :: XmlEncoding+_ISO8859_8_ = XmlEncoding iso8859_8++_ISO8859_9_ :: XmlEncoding+_ISO8859_9_ = XmlEncoding iso8859_9++_ISO8859_10_ :: XmlEncoding+_ISO8859_10_ = XmlEncoding iso8859_10++_ISO8859_11_ :: XmlEncoding+_ISO8859_11_ = XmlEncoding iso8859_11++_ISO8859_13_ :: XmlEncoding+_ISO8859_13_ = XmlEncoding iso8859_13++_ISO8859_14_ :: XmlEncoding+_ISO8859_14_ = XmlEncoding iso8859_14++_ISO8859_15_ :: XmlEncoding+_ISO8859_15_ = XmlEncoding iso8859_15++_ISO8859_16_ :: XmlEncoding+_ISO8859_16_ = XmlEncoding iso8859_16++_USASCII_ :: XmlEncoding+_USASCII_ = XmlEncoding usAscii++_UCS2_ :: XmlEncoding+_UCS2_ = XmlEncoding ucs2++_UTF8_ :: XmlEncoding+_UTF8_ = XmlEncoding utf8++_UTF16_ :: XmlEncoding+_UTF16_ = XmlEncoding utf16++_UTF16BE_ :: XmlEncoding+_UTF16BE_ = XmlEncoding utf16be++_UTF16LE_ :: XmlEncoding+_UTF16LE_ = XmlEncoding utf16le++_ISOLATIN1_ :: XmlEncoding+_ISOLATIN1_ = XmlEncoding isoLatin1++++-- == ENCODING FUNCTIONS ======================================================++xmlEncodingFromString :: String -> Either String XmlEncoding+xmlEncodingFromString name =+ case map toLower name of+ "latin1" -> return _ISOLATIN1_+ "latin9" -> return _ISO8859_15_+ "iso-8859-1" -> return _ISO8859_1_+ "iso-8859-2" -> return _ISO8859_2_+ "iso-8859-3" -> return _ISO8859_3_+ "iso-8859-4" -> return _ISO8859_4_+ "iso-8859-5" -> return _ISO8859_5_+ "iso-8859-6" -> return _ISO8859_6_+ "iso-8859-7" -> return _ISO8859_7_+ "iso-8859-8" -> return _ISO8859_8_+ "iso-8859-9" -> return _ISO8859_9_+ "iso-8859-10" -> return _ISO8859_10_+ "iso-8859-11" -> return _ISO8859_11_+ "iso-8859-13" -> return _ISO8859_13_+ "iso-8859-14" -> return _ISO8859_14_+ "iso-8859-15" -> return _ISO8859_15_+ "utf8" -> return _UTF8_+ "utf-8" -> return _UTF8_+ "utf16" -> return _UTF16_+ "utf-16" -> return _UTF16_+ "ascii" -> return _USASCII_+ "us-ascii" -> return _USASCII_+ "unicode" -> return _UNICODE_+ _ -> fail $ "Can't parse unsupported XmlEncoding name `" ++ name ++ "'."++xmlEncodingToString :: XmlEncoding -> String+xmlEncodingToString = show++xmlEncoding :: Monad m => BSL.ByteString -> m DynEncoding+xmlEncoding bs =+ let enc = case parseProlog of+ Nothing -> "UTF-8"+ Just s -> s+ in case encodingFromStringExplicit enc of+ Just e -> return e+ Nothing -> fail $ "unknown encoding: " ++ enc+ where+ parseProlog =+ do M.when (BSLChar.take 5 bs /= BSLChar.pack "<?xml") $ fail "no xml prolog"+ (header, _) <- breakSubstring' (BSLChar.pack "?>") bs+ (_, rest) <- breakSubstring' (BSLChar.pack "encoding") header+ let notQuote = \c -> c /= '"' && c /= '\''+ enc = (BSLChar.takeWhile notQuote . -- get the encoding+ BSLChar.drop 1 . -- drop quote+ BSLChar.dropWhile notQuote) -- skip to first quote+ rest+ return $ BSLChar.unpack enc+ breakSubstring' x bs =+ let (prefix, y) = breakSubstring x bs+ in if x `BSL.isPrefixOf` y+ then return (prefix, BSL.drop (BSL.length x) y)+ else fail ("breakSubstring failed: substring " ++ show x+ ++ " not contained in " ++ show bs)+ breakSubstring x bs =+ if x `BSL.isPrefixOf` bs+ then (BSL.empty, bs)+ else case BSL.uncons bs of+ Nothing -> (BSL.empty, BSL.empty)+ Just (c, bs') ->+ let (bs1, bs2) = breakSubstring x bs'+ in (BSL.cons c bs1, bs2)++-- == XML FUNCTIONS ===========================================================++xpOne :: PU a -> PU a+xpOne = id++xpMany :: String -> PU a -> PU [a]+xpMany rootName pu = xpElem rootName (xpList pu)++xpByteString :: PU BSL.ByteString+xpByteString = xpWrap (BSLChar.pack, BSLChar.unpack) xpText0++pickle :: PU a -> a -> BSLChar.ByteString+pickle pu = serializeXml _UTF8_ . pickleDoc pu++pickleWithEnc :: XmlEncoding -> PU a -> a -> BSLChar.ByteString+pickleWithEnc enc pu = serializeXml' noProlog enc . pickleDoc pu+ where noProlog = enc == _UNICODE_++unpickle :: Monad m => PU a -> BSLChar.ByteString -> m a+unpickle pu bsl = parseXml defaultParseXmlConfig bsl >>= unpickleDocM pu++validateAndUnpickle :: XmlValidator -> PU a -> BSLChar.ByteString -> Either String a+validateAndUnpickle val pu bsl =+ case val bsl of+ Left s -> Left s+ _ ->+ case parseXml defaultParseXmlConfig bsl of+ Right t -> unpickleDocM pu t+ Left s -> Left s++pickleStr :: PU a -> a -> String+pickleStr pu = BSLChar.unpack . pickleWithEnc _UNICODE_ pu++unpickleDocM :: Monad m => PU a -> XmlTree -> m a+unpickleDocM pu t =+ case unpickleDoc pu t of+ Nothing -> fail "Unpickling failed."+ Just x -> return x++unpickleStr :: Monad m => PU a -> [Char] -> m a+unpickleStr pu = unpickle pu . BSLChar.pack++serializeXml :: XmlEncoding -> XmlTree -> BSLChar.ByteString+serializeXml enc xml = serializeXml' False enc xml++serializeXml' :: Bool -> XmlEncoding -> XmlTree -> BSLChar.ByteString+serializeXml' indent enc xml =+ let [str] = runLA (constA xml >>> encodeA) (error "serializeXml': undefined")+ in (BSLChar.pack (strip str))+ where rmpi = enc == _UNICODE_+ encodeA =+ processChildren (uniqueNamespacesFromDeclAndQNames)+ >>>+ (if indent then processChildren indentDoc else this)+ >>>+ escapeXmlDoc+ >>>+ encodeDocument' rmpi (xmlEncodingName enc)+ >>>+ replaceChildren (xshow getChildren >>> arr encode >>> mkText)+ >>>+ xshow getChildren+ encode = id+ strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace+ isSpace = (`elem` " \n\t")++data ParseXmlConfig = ParseXmlConfig { pxml_removeProcessingInstructions :: Bool+ , pxml_removeNonSignificantWhitespace :: Bool+ , pxml_removeComments :: Bool }++defaultParseXmlConfig :: ParseXmlConfig+defaultParseXmlConfig = ParseXmlConfig True True True++parseXml :: Monad m => ParseXmlConfig -> BSLChar.ByteString -> m XmlTree+parseXml cfg bstr =+ do enc <- xmlEncoding bstr+ case decodeLazyByteStringExplicit enc bstr of+ Left err -> fail (show err)+ Right str ->+ let trees = runLA (pipe str) (error "parseXml: undefined")+ in case trees of+ [] -> fail "empty result"+ (NTree _ ((NTree (XError _ msg) _) : _) : _) -> fail msg+ trees' -> return (last trees')+ where pipe str = root [] []+ >>> replaceChildren (parse str)+ >>> (if pxml_removeProcessingInstructions cfg then removeXmlPi else this)+ >>> (if pxml_removeNonSignificantWhitespace cfg then removeDocWhiteSpace else this)+ >>> (if pxml_removeComments cfg then removeAllComment else this)+ parse str = constA ("urn:Data.ByteString", str)+ >>> parseXmlDoc+ >>> substXmlEntityRefs+ >>> canonicalizeContents+ >>> propagateNamespaces++removeXmlPi :: ArrowXml a => a (NTree XNode) (NTree XNode)+removeXmlPi = processTopDown (none `when` (isPi >>> hasName t_xml))++data PUCase a = PUCase { case_value :: a+ , case_spec :: PU a }++xpCase :: (a -> b, b -> a) -> PU a -> PUCase b+xpCase wrapfuns@(aToB,_bToA) specA = PUCase value spec+ where value = aToB (error "xpCase: tagging function requires evaluation")+ spec = xpWrap wrapfuns specA++xpCaseConst :: a -> PU () -> PUCase a+xpCaseConst a pu = xpCase (const a, const $ error undef) pu+ where undef = error "xpCaseConst: this value should have been ignored"++xpSwitch :: Show a => [PUCase a] -> PU a+xpSwitch = xpTagSwitch (takeWhile (/= ' ') . show)++xpTagSwitch :: Eq t => (a -> t) -> [PUCase a] -> PU a+xpTagSwitch tag cases = xpAlt idx (map case_spec cases)+ where idx = fromMaybe err . flip elemIndex tags . tag+ err = error $ "xpTagSwitch: no case matched"+ tags = map (tag . case_value) cases++xpTextFixed :: String -> PU ()+xpTextFixed text =+ (xpWrapMaybe (\t -> if t == text then Just () else Nothing, const text)+ xpText) { theSchema = scFixed text }++xpConsumeAll :: PU a -> PU a+xpConsumeAll pu =+ PU { appPickle = appPickle pu+ , appUnPickle = \s1 -> case appUnPickle pu s1 of+ r@(Nothing, _) -> r+ r@(Just _, s2) ->+ case contents s2 of+ [] -> r+ _ -> (Nothing, s2)+ , theSchema = theSchema pu+ }++xpIgnoreOnUnpickle :: (PU a -> PU a) -> PU a -> PU a+xpIgnoreOnUnpickle tf pu =+ PU { appPickle = appPickle (tf pu)+ , appUnPickle = appUnPickle pu+ , theSchema = theSchema pu+ }++xpExhaustiveList :: PU a -> PU [a]+xpExhaustiveList = xpConsumeAll . xpList++xpEither :: (Show a, Show b) => PU a -> PU b -> PU (Either a b)+xpEither xpL xpR =+ xpSwitch+ [ xpCase (Left, \(Left l) -> l) xpL+ , xpCase (Right, \(Right r) -> r) xpR+ ]