1 {-# LANGUAGE TypeFamilies #-}
3 -- | General XML stuff.
13 import Control.Exception ( SomeException(..), catch )
14 import Text.XML.HXT.Core (
29 -- | A typeclass for XML types that can be converted into an
30 -- associated database type. The story behind this is long, but
31 -- basically, we need to different types most XML thingies we're
32 -- going to import: a database type and an XML type.
34 -- Both Groundhog and HXT are very particular about the types that
35 -- they can use, and there's no way to reuse e.g. a type that HXT
36 -- can pickle in Groundhog. This typeclass gives us a standard way
37 -- to get the database type from the XML type that we have to define
41 -- | Each instance @a@ must declare its associated database type @Db a@.
44 -- | And provide a function for getting a @Db a@ out of an @a@.
48 -- | Represents the DTD filename (\"SYSTEM\") part of the DOCTYPE
50 newtype DtdName = DtdName String
52 -- | A list of options passed to 'readDocument' when we parse an XML
53 -- document. All cosmetic whitespace should be removed, otherwise we
54 -- would have to parse whitespace in each (un)pickler.
56 parse_opts :: SysConfigList
57 parse_opts = [ withRemoveWS yes ]
60 -- | Given a root element name and a file path, return both the
61 -- original unpickled root \"object\" and the one that was
62 -- constructed by pickled and unpickling the original. This is used
63 -- in a number of XML tests which pickle/unpickle and then make sure
64 -- that the output is the same as the input.
66 -- We return the object instead of an XmlTree (which would save us
67 -- an unpickle call) because otherwise the type of @a@ in the call
68 -- to 'xpickle' would be ambiguous. By returning some @a@s, we allow
69 -- the caller to annotate its type.
71 -- Note that this will happily pickle nothing to nothing and then
72 -- unpickle it back to more nothing. So the fact that the
73 -- before/after results from this function agree does not mean that
74 -- the document was successfully unpickled!
76 pickle_unpickle :: XmlPickler 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
90 return (expected, actual)
92 arr_getobj = readDocument parse_opts filepath
100 -- | Is the given XML file unpickleable? Unpickling will be attempted
101 -- using the @unpickler@ argument. If we unilaterally used the
102 -- generic 'xpickle' function for our unpickler, a type ambiguity
103 -- would result. By taking the unpickler as an argument, we allow
104 -- the caller to indirectly specify a concrete type.
106 -- Apologies the the name; unpickleable means \"we can unpickle
107 -- it\", not \"not pickleable.\"
109 unpickleable :: XmlPickler a => FilePath -> PU a -> IO Bool
110 unpickleable filepath unpickler = do
111 xmldoc <- try_unpickle `catch` (\(SomeException _) -> return [])
112 return $ (not . null) xmldoc
114 try_unpickle = runX $ readDocument parse_opts filepath
116 xunpickleVal unpickler