{-# 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 )
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,
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
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 =
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
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
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
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
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
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
"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
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
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
unpickleable )
where
+-- System imports.
import Control.Exception ( SomeException(..), catch )
import Text.XML.HXT.Core (
(>>>),
PU,
SysConfigList,
XmlPickler(..),
- hasName,
+ isElem,
readDocument,
runX,
withRemoveWS,
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
-- 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
-- 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
projects / dead / htsn-import.git / commitdiff