From: Michael Orlitzky Date: Mon, 13 Jan 2014 03:54:15 +0000 (-0500) Subject: Simplify some tests by passing a pickler instead of relying on a XmlPickler instance. X-Git-Tag: 0.0.1~86 X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=4cdcdbe593c30f6434a25896951a1a4dfcc2b1ca;p=dead%2Fhtsn-import.git Simplify some tests by passing a pickler instead of relying on a XmlPickler instance. --- diff --git a/src/TSN/XML/Heartbeat.hs b/src/TSN/XML/Heartbeat.hs index bcf9069..588c75c 100644 --- a/src/TSN/XML/Heartbeat.hs +++ b/src/TSN/XML/Heartbeat.hs @@ -1,10 +1,13 @@ {-# LANGUAGE ScopedTypeVariables #-} +-- | Handle documents defined by Heartbeat.dtd. +-- module TSN.XML.Heartbeat ( heartbeat_tests, verify ) where +-- System imports. import Data.Tuple.Curry ( uncurryN ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) @@ -15,13 +18,17 @@ import Text.XML.HXT.Core ( XmlTree, xpTriple, xpElem, - xpPrim, + xpInt, xpText, xpWrap ) +-- Local imports. import TSN.DbImport ( ImportResult(..) ) import Xml ( pickle_unpickle, unpickleable ) + +-- | The data structure that holds the XML representation of a +-- Heartbeat message. data Message = Message { xml_file_id :: Int, @@ -29,11 +36,14 @@ data Message = time_stamp :: String } deriving (Eq, Show) + +-- | A (un)pickler that turns a Heartbeat XML file into a 'Message' +-- and vice-versa. pickle_message :: PU Message pickle_message = xpElem "message" $ xpWrap (from_tuple, to_tuple) $ - xpTriple (xpElem "XML_File_ID" xpPrim) + xpTriple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "time_stamp" xpText) where @@ -42,20 +52,19 @@ pickle_message = heading m, time_stamp m) -instance XmlPickler Message where - xpickle = pickle_message - --- | Verify (and report) the received heartbeat. We always return --- Nothing to avoid spurious "successfully imported..." notices. +-- | Verify (and report) the received heartbeat. We return +-- 'ImportSkipped' because we want to indicate that we processed the +-- file but there was nothing to import. -- verify :: XmlTree -> IO ImportResult verify xml = do - let root_element = unpickleDoc xpickle xml :: Maybe Message + let root_element = unpickleDoc pickle_message xml return $ case root_element of Nothing -> ImportFailed "Could not unpickle document in import_generic." Just _ -> ImportSkipped "Heartbeat received. Thump." + -- * Tasty Tests heartbeat_tests :: TestTree heartbeat_tests = @@ -65,16 +74,19 @@ heartbeat_tests = test_unpickle_succeeds ] --- | Warning, succeess of this test does not mean that unpickling +-- | Warning: succeess of this test does not mean that unpickling -- succeeded. +-- test_pickle_of_unpickle_is_identity :: TestTree test_pickle_of_unpickle_is_identity = testCase "pickle composed with unpickle is the identity" $ do let path = "test/xml/Heartbeat.xml" - (expected :: [Message], actual) <- pickle_unpickle "message" path + (expected :: [Message], actual) <- pickle_unpickle pickle_message path actual @?= expected +-- | Make sure we can unpickle the sample file. +-- test_unpickle_succeeds :: TestTree test_unpickle_succeeds = testCase "unpickling succeeds" $ do diff --git a/src/TSN/XML/Injuries.hs b/src/TSN/XML/Injuries.hs index 8b3f8d1..7ffca26 100644 --- a/src/TSN/XML/Injuries.hs +++ b/src/TSN/XML/Injuries.hs @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -169,7 +168,7 @@ test_pickle_of_unpickle_is_identity :: TestTree test_pickle_of_unpickle_is_identity = testCase "pickle composed with unpickle is the identity" $ do let path = "test/xml/injuriesxml.xml" - (expected :: [Message], actual) <- pickle_unpickle "message" path + (expected, actual) <- pickle_unpickle pickle_message path actual @?= expected diff --git a/src/TSN/XML/InjuriesDetail.hs b/src/TSN/XML/InjuriesDetail.hs index 695fe86..431eec1 100644 --- a/src/TSN/XML/InjuriesDetail.hs +++ b/src/TSN/XML/InjuriesDetail.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -187,7 +186,7 @@ test_pickle_of_unpickle_is_identity :: TestTree test_pickle_of_unpickle_is_identity = testCase "pickle composed with unpickle is the identity" $ do let path = "test/xml/Injuries_Detail_XML.xml" - (expected :: [Message], actual) <- pickle_unpickle "message" path + (expected, actual) <- pickle_unpickle pickle_message path actual @?= expected diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs index f799a52..67611e5 100644 --- a/src/TSN/XML/News.hs +++ b/src/TSN/XML/News.hs @@ -3,7 +3,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -362,7 +361,7 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" "test/xml/newsxml-with-editor.xml" ] where check desc path = testCase desc $ do - (expected :: [Message], actual) <- pickle_unpickle "message" path + (expected, actual) <- pickle_unpickle pickle_message path actual @?= expected diff --git a/src/TSN/XML/Odds.hs b/src/TSN/XML/Odds.hs index 2105ce7..3a508ee 100644 --- a/src/TSN/XML/Odds.hs +++ b/src/TSN/XML/Odds.hs @@ -3,7 +3,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -539,7 +538,7 @@ test_pickle_of_unpickle_is_identity :: TestTree test_pickle_of_unpickle_is_identity = testCase "pickle composed with unpickle is the identity" $ do let path = "test/xml/Odds_XML.xml" - (expected :: [Message], actual) <- pickle_unpickle "message" path + (expected, actual) <- pickle_unpickle pickle_message path actual @?= expected diff --git a/src/Xml.hs b/src/Xml.hs index e8b7c4d..866ac46 100644 --- a/src/Xml.hs +++ b/src/Xml.hs @@ -10,6 +10,7 @@ module Xml ( unpickleable ) where +-- System imports. import Control.Exception ( SomeException(..), catch ) import Text.XML.HXT.Core ( (>>>), @@ -17,7 +18,7 @@ import Text.XML.HXT.Core ( PU, SysConfigList, XmlPickler(..), - hasName, + isElem, readDocument, runX, withRemoveWS, @@ -57,11 +58,12 @@ parse_opts :: SysConfigList parse_opts = [ withRemoveWS yes ] --- | Given a root element name and a file path, return both the --- original unpickled root \"object\" and the one that was --- constructed by pickled and unpickling the original. This is used --- in a number of XML tests which pickle/unpickle and then make sure --- that the output is the same as the input. +-- | Given an @unpickler@ and a @filepath@, attempt to unpickle the +-- root element of @filepath@ using @unpickler@ and return both the +-- original unpickled object and one constructed by pickling and +-- unpickling that original. This is used in a number of XML tests +-- which pickle/unpickle and then make sure that the output is the +-- same as the input. -- -- We return the object instead of an XmlTree (which would save us -- an unpickle call) because otherwise the type of @a@ in the call @@ -73,27 +75,26 @@ parse_opts = [ withRemoveWS yes ] -- before/after results from this function agree does not mean that -- the document was successfully unpickled! -- -pickle_unpickle :: XmlPickler a - => String - -> FilePath +pickle_unpickle :: PU a -- ^ @unpickler@ returning an @a@ + -> FilePath -- ^ Path to the document to unpickle. -> IO ([a], [a]) -pickle_unpickle root_element filepath = do +pickle_unpickle unpickler filepath = do -- We need to check only the root message element since -- readDocument produces a bunch of other junk. expected <- runX arr_getobj actual <- runX $ arr_getobj >>> - xpickleVal xpickle + xpickleVal unpickler >>> - xunpickleVal xpickle + xunpickleVal unpickler return (expected, actual) where arr_getobj = readDocument parse_opts filepath /> - hasName root_element + isElem -- Drop the extra junk readDocument pulls in. >>> - xunpickleVal xpickle + xunpickleVal unpickler @@ -106,7 +107,7 @@ pickle_unpickle root_element filepath = do -- Apologies the the name; unpickleable means \"we can unpickle -- it\", not \"not pickleable.\" -- -unpickleable :: XmlPickler a => FilePath -> PU a -> IO Bool +unpickleable :: FilePath -> PU a -> IO Bool unpickleable filepath unpickler = do xmldoc <- try_unpickle `catch` (\(SomeException _) -> return []) return $ (not . null) xmldoc