src/Xml.hs

   1 {-# LANGUAGE TypeFamilies #-}
   2
   3 -- | General XML stuff.
   4 --
   5 module Xml (
   6   FromXml(..),
   7   parse_opts,
   8   pickle_unpickle )
   9 where
  10
  11 import Text.XML.HXT.Core (
  12   (>>>),
  13   (/>),
  14   SysConfigList,
  15   XmlPickler(..),
  16   hasName,
  17   no,
  18   readDocument,
  19   runX,
  20   withPreserveComment,
  21   withRemoveWS,
  22   withSubstDTDEntities,
  23   withValidate,
  24   xpickleVal,
  25   xunpickleVal,
  26   yes )
  27
  28
  29 -- | A typeclass for types which can be converted into an associated
  30 --   XML type. The story behind this is long, but basically, we need
  31 --   to different types for each XML thingie we're going to import: a
  32 --   database type and an XML type. Both Groundhog and HXT are very
  33 --   particular about the types that they can use, and there's no way
  34 --   to reuse e.g. a type that HXT can pickle in Groundhog. So this
  35 --   typeclass gives us a way to get the XML type from the Groundhog
  36 --   type.
  37 --
  38 --   At first there appears to be an equally-valid approach, getting the
  39 --   Groundhog type from the XML one. But Groundhog won't use type family
  40 --   instances, so here we are.
  41 --
  42 class FromXml a where
  43   -- | Each instance a must declare its associated XML type (Xml a)
  44   type Xml a :: *
  45
  46   -- | And provide a function for getting an (Xml a) out of an "a."
  47   to_xml :: a -> Xml a
  48
  49
  50 -- | A list of options passed to 'readDocument' when we parse an XML
  51 --   document. We don't validate because the DTDs from TSN are
  52 --   wrong. As a result, we don't want to keep useless DTDs
  53 --   areound. Thus we disable 'withSubstDTDEntities' which, when
  54 --   combined with "withValidate no", prevents HXT from trying to read
  55 --   the DTD at all.
  56 --
  57 parse_opts :: SysConfigList
  58 parse_opts =
  59   [ withPreserveComment no,
  60     withRemoveWS yes,
  61     withSubstDTDEntities no,
  62     withValidate no ]
  63
  64
  65 -- | Given a root element name and a file path, return both the
  66 --   original unpickled root "object" and the one that was constructed
  67 --   by pickled and unpickling the original. This is used in a number
  68 --   of XML tests which pickle/unpickle and then make sure that the
  69 --   output is the same as the input.
  70 --
  71 --   We return the object instead of an XmlTree (which would save us
  72 --   an unpickle call) because otherwise the type of @a@ in the call
  73 --   to 'xpickle' would be ambiguous. By returning some @a@s, we allow
  74 --   the caller to annotate its type.
  75 --
  76 pickle_unpickle :: XmlPickler a
  77                 => String
  78                 -> FilePath
  79                 -> IO ([a], [a])
  80 pickle_unpickle root_element filepath = do
  81   -- We need to check only the root message element since
  82   -- readDocument produces a bunch of other junk.
  83     expected <- runX $ arr_getobj
  84     actual <- runX $ arr_getobj
  85                      >>>
  86                      xpickleVal xpickle
  87                      >>>
  88                      xunpickleVal xpickle
  89
  90     return (expected, actual)
  91   where
  92     arr_getobj = readDocument parse_opts filepath
  93                    />
  94                    hasName root_element
  95                    >>>
  96                    xunpickleVal xpickle