From: Michael Orlitzky <michael@orlitzky.com>
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: http://gitweb.michael.orlitzky.com/?p=dead%2Fhtsn-import.git;a=commitdiff_plain;h=4cdcdbe593c30f6434a25896951a1a4dfcc2b1ca

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