diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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" diff --git a/hxthelper.cabal b/hxthelper.cabal new file mode 100644 --- /dev/null +++ b/hxthelper.cabal @@ -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 +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 diff --git a/src/Text/XML/HXT/Helper.hs b/src/Text/XML/HXT/Helper.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/HXT/Helper.hs @@ -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 "") 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 + ]