From: Michael Orlitzky Date: Thu, 2 Jan 2014 05:10:54 +0000 (-0500) Subject: Add 'unpickleable' to Xml for use in tests. X-Git-Tag: 0.0.1~124 X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=10e7a7d5c354cdaa47d479f785a76eb6bf49e535;p=dead%2Fhtsn-import.git Add 'unpickleable' to Xml for use in tests. --- diff --git a/src/Xml.hs b/src/Xml.hs index 96ba011..2f68dd0 100644 --- a/src/Xml.hs +++ b/src/Xml.hs @@ -6,13 +6,16 @@ module Xml ( DtdName(..), ToFromXml(..), parse_opts, - pickle_unpickle ) + pickle_unpickle, + unpickleable ) where +import Control.Exception ( SomeException(..), catch ) import Database.Groundhog ( AutoKey ) import Text.XML.HXT.Core ( (>>>), (/>), + PU, SysConfigList, XmlPickler(..), hasName, @@ -91,6 +94,11 @@ parse_opts = -- to 'xpickle' would be ambiguous. By returning some @a@s, we allow -- the caller to annotate its type. -- +-- Note that this will happily pickle nothing to nothing and then +-- unpickle it back to more nothing. So the fact that the +-- before/after results from this function agree does not mean that +-- the document was successfully unpickled! +-- pickle_unpickle :: XmlPickler a => String -> FilePath @@ -112,3 +120,20 @@ pickle_unpickle root_element filepath = do hasName root_element >>> xunpickleVal xpickle + + + +-- | Is the given XML file unpickleable? Unpickling will be attempted +-- using the @unpickler@ argument. If we unilaterally used the +-- generic 'xpickle' function for our unpickler, a type ambiguity +-- would result. By taking the unpickler as an argument, we allow +-- the caller to indirectly specify a concrete type. +-- +unpickleable :: XmlPickler a => FilePath -> PU a -> IO Bool +unpickleable filepath unpickler = do + xmldoc <- try_unpickle `catch` (\(SomeException _) -> return []) + return $ (not . null) xmldoc + where + try_unpickle = runX $ readDocument parse_opts filepath + >>> + xunpickleVal unpickler