1 {-# LANGUAGE TypeFamilies #-}
3 -- | General XML stuff.
14 import Control.Exception ( SomeException(..), catch )
15 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 an @unpickler@ and a @filepath@, attempt to unpickle the
61 -- root element of @filepath@ using @unpickler@ and return both the
62 -- original unpickled object and one constructed by pickling and
63 -- unpickling that original. This is used in a number of XML tests
64 -- which pickle/unpickle and then make sure that the output is the
67 -- We return the object instead of an XmlTree (which would save us
68 -- an unpickle call) because otherwise the type of @a@ in the call
69 -- to 'xpickle' would be ambiguous. By returning some @a@s, we allow
70 -- the caller to annotate its type.
72 -- Note that this will happily pickle nothing to nothing and then
73 -- unpickle it back to more nothing. So the fact that the
74 -- before/after results from this function agree does not mean that
75 -- the document was successfully unpickled!
77 pickle_unpickle :: PU a -- ^ @unpickler@ returning an @a@
78 -> FilePath -- ^ Path to the document to unpickle.
80 pickle_unpickle unpickler 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
88 xunpickleVal unpickler
90 return (expected, actual)
92 arr_getobj = readDocument parse_opts filepath
94 isElem -- Drop the extra junk readDocument pulls in.
96 xunpickleVal unpickler
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 :: 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