src/Xml.hs

   1 -- | General XML stuff.
   2 --
   3 module Xml (
   4   parse_opts,
   5   pickle_unpickle )
   6 where
   7
   8 import Text.XML.HXT.Core (
   9   (>>>),
  10   (/>),
  11   SysConfigList,
  12   XmlPickler(..),
  13   hasName,
  14   no,
  15   readDocument,
  16   runX,
  17   withPreserveComment,
  18   withRemoveWS,
  19   withSubstDTDEntities,
  20   withValidate,
  21   xpickleVal,
  22   xunpickleVal,
  23   yes )
  24
  25 -- | A list of options passed to 'readDocument' when we parse an XML
  26 --   document. We don't validate because the DTDs from TSN are
  27 --   wrong. As a result, we don't want to keep useless DTDs
  28 --   areound. Thus we disable 'withSubstDTDEntities' which, when
  29 --   combined with "withValidate no", prevents HXT from trying to read
  30 --   the DTD at all.
  31 --
  32 parse_opts :: SysConfigList
  33 parse_opts =
  34   [ withPreserveComment no,
  35     withRemoveWS yes,
  36     withSubstDTDEntities no,
  37     withValidate no ]
  38
  39
  40 -- | Given a root element name and a file path, return both the
  41 --   original unpickled root "object" and the one that was constructed
  42 --   by pickled and unpickling the original. This is used in a number
  43 --   of XML tests which pickle/unpickle and then make sure that the
  44 --   output is the same as the input.
  45 --
  46 --   We return the object instead of an XmlTree (which would save us
  47 --   an unpickle call) because otherwise the type of @a@ in the call
  48 --   to 'xpickle' would be ambiguous. By returning some @a@s, we allow
  49 --   the caller to annotate its type.
  50 --
  51 pickle_unpickle :: XmlPickler a
  52                 => String
  53                 -> FilePath
  54                 -> IO ([a], [a])
  55 pickle_unpickle root_element filepath = do
  56   -- We need to check only the root message element since
  57   -- readDocument produces a bunch of other junk.
  58     expected <- runX $ arr_getobj
  59     actual <- runX $ arr_getobj
  60                      >>>
  61                      xpickleVal xpickle
  62                      >>>
  63                      xunpickleVal xpickle
  64
  65     return (expected, actual)
  66   where
  67     arr_getobj = readDocument parse_opts filepath
  68                    />
  69                    hasName root_element
  70                    >>>
  71                    xunpickleVal xpickle