+-- | General XML stuff.
+--
+module Xml (
+ parse_opts,
+ pickle_unpickle )
+where
+
+import Text.XML.HXT.Core (
+ (>>>),
+ (/>),
+ SysConfigList,
+ XmlPickler(..),
+ hasName,
+ no,
+ readDocument,
+ runX,
+ withPreserveComment,
+ withRemoveWS,
+ withSubstDTDEntities,
+ withValidate,
+ xpickleVal,
+ xunpickleVal,
+ yes )
+
+-- | A list of options passed to 'readDocument' when we parse an XML
+-- document. We don't validate because the DTDs from TSN are
+-- wrong. As a result, we don't want to keep useless DTDs
+-- areound. Thus we disable 'withSubstDTDEntities' which, when
+-- combined with "withValidate no", prevents HXT from trying to read
+-- the DTD at all.
+--
+parse_opts :: SysConfigList
+parse_opts =
+ [ withPreserveComment no,
+ withRemoveWS yes,
+ withSubstDTDEntities no,
+ withValidate no ]
+
+
+-- | Given a root element name and a file path, return both the
+-- original unpickled root "object" and the one that was constructed
+-- by pickled and unpickling the original. This is used in a number
+-- of XML tests which pickle/unpickle and then make sure that the
+-- output is the same as the input.
+--
+-- We return the object instead of an XmlTree (which would save us
+-- an unpickle call) because otherwise the type of @a@ in the call
+-- to 'xpickle' would be ambiguous. By returning some @a@s, we allow
+-- the caller to annotate its type.
+--
+pickle_unpickle :: XmlPickler a
+ => String
+ -> FilePath
+ -> IO ([a], [a])
+pickle_unpickle root_element filepath = do
+ -- We need to check only the root message element since
+ -- readDocument produces a bunch of other junk.
+ expected <- runX $ arr_getobj
+ actual <- runX $ arr_getobj
+ >>>
+ xpickleVal xpickle
+ >>>
+ xunpickleVal xpickle
+
+ return (expected, actual)
+ where
+ arr_getobj = readDocument parse_opts filepath
+ />
+ hasName root_element
+ >>>
+ xunpickleVal xpickle