Add a new module, TSN.XML.MLBEarlyLines supporting MLB_earlylinesXML.dtd.

[dead/htsn-import.git] / src / TSN / XML / MLBEarlyLine.hs

diff --git a/src/TSN/XML/MLBEarlyLine.hs b/src/TSN/XML/MLBEarlyLine.hs
new file mode 100644 (file)
index 0000000..fc90483
--- /dev/null
+++ b/src/TSN/XML/MLBEarlyLine.hs
@@ -0,0 +1,136 @@
+-- | Parse TSN XML for the DTD \"MLB_earlylineXML.dtd\". This module
+--   is unique (so far) in that it is almost entirely a subclass of
+--   another module, "TSN.XML.EarlyLine". The database representations
+--   should be almost identical, and the XML schema /could/ be
+--   similar, but instead, welcome to the jungle baby. Here are the
+--   differences:
+--
+--   * In earlylineXML.dtd, each \<date\> element contains exactly one
+--     game. In MLB_earlylineXML.dtd, they contain multiple games.
+--
+--   * As a result of the previous difference, the \<note\>s are no
+--     longer in one-to-one correspondence with the games. The
+--     \<note\> elements are thrown in beside the \<game\>s, and we're
+--     supposed to figure out to which \<game\>s they correspond
+--     ourselves. This is the same sort of nonsense going on with
+--     'TSN.XML.Odds.OddsGameWithNotes'.
+--
+--    * The \<over_under\> element can be empty in
+--      MLB_earlylineXML.dtd (it can't in earlylineXML.dtd).
+--
+--   * Each home/away team in MLB_earlylineXML.dtd has a \<pitcher\>
+--     that isn't present in the regular earlylineXML.dtd.
+--
+--   * In earlylineXML.dtd, the home/away team lines are given as
+--     attributes on the \<teamH\> and \<teamA\> elements
+--     respectively. In MLB_earlylineXML.dtd, the lines can be found
+--     in \<line\> elements that are children of the \<teamH\> and
+--     \<teamA\> elements.
+--
+--   * In earlylineXML.dtd, the team names are given as text within
+--     the \<teamA\> and \<teamH\> elements. In MLB_earlylineXML.dtd,
+--     they are instead given as attributes on those respective
+--     elements.
+--
+--   Most of these difficulties have been worked around in
+--   "TSN.XML.EarlyLine", so this module could be kept somewhat boring.
+--
+module TSN.XML.MLBEarlyLine (
+  dtd,
+  mlb_early_line_tests,
+  module TSN.XML.EarlyLine -- This re-exports the EarlyLine and EarlyLineGame
+                           -- constructors unnecessarily. Whatever.
+  )
+where
+
+-- System imports (needed only for tests)
+import Database.Groundhog (
+  countAll,
+  deleteAll,
+  migrate,
+  runMigration,
+  silentMigrationLogger )
+import Database.Groundhog.Generic ( runDbConn )
+import Database.Groundhog.Sqlite ( withSqliteConn )
+import Test.Tasty ( TestTree, testGroup )
+import Test.Tasty.HUnit ( (@?=), testCase )
+
+
+-- Local imports.
+import TSN.DbImport ( DbImport( dbimport ) )
+import TSN.XML.EarlyLine ( EarlyLine, EarlyLineGame, pickle_message )
+import Xml (
+  pickle_unpickle,
+  unpickleable,
+  unsafe_unpickle )
+
+
+-- | The DTD to which this module corresponds. Used to invoke dbimport.
+--
+dtd :: String
+dtd = "MLB_earlylineXML.dtd"
+
+
+
+--
+-- * Tasty Tests
+--
+
+-- | A list of all tests for this module.
+--
+mlb_early_line_tests :: TestTree
+mlb_early_line_tests =
+  testGroup
+    "MLBEarlyLine tests"
+    [ test_on_delete_cascade,
+      test_pickle_of_unpickle_is_identity,
+      test_unpickle_succeeds ]
+
+-- | If we unpickle something and then pickle it, we should wind up
+--   with the same thing we started with. WARNING: success 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/MLB_earlylineXML.xml"
+    (expected, actual) <- pickle_unpickle pickle_message path
+    actual @?= expected
+
+
+
+-- | Make sure we can actually unpickle these things.
+--
+test_unpickle_succeeds :: TestTree
+test_unpickle_succeeds =
+  testCase "unpickling succeeds" $ do
+    let path = "test/xml/MLB_earlylineXML.xml"
+    actual <- unpickleable path pickle_message
+
+    let expected = True
+    actual @?= expected
+
+
+
+-- | Make sure everything gets deleted when we delete the top-level
+--   record.
+--
+test_on_delete_cascade :: TestTree
+test_on_delete_cascade =
+  testCase "deleting (MLB) early_lines deletes its children" $ do
+    let path = "test/xml/MLB_earlylineXML.xml"
+    results <- unsafe_unpickle path pickle_message
+    let a = undefined :: EarlyLine
+    let b = undefined :: EarlyLineGame
+
+    actual <- withSqliteConn ":memory:" $ runDbConn $ do
+                runMigration silentMigrationLogger $ do
+                  migrate a
+                  migrate b
+                _ <- dbimport results
+                deleteAll a
+                count_a <- countAll a
+                count_b <- countAll b
+                return $ sum [count_a, count_b]
+    let expected = 0
+    actual @?= expected