src/TSN/XML/MLBEarlyLine.hs

   1 -- | Parse TSN XML for the DTD \"MLB_earlylineXML.dtd\". This module
   2 --   is unique (so far) in that it is almost entirely a subclass of
   3 --   another module, "TSN.XML.EarlyLine". The database representations
   4 --   should be almost identical, and the XML schema /could/ be
   5 --   similar, but instead, welcome to the jungle baby. Here are the
   6 --   differences:
   7 --
   8 --   * In earlylineXML.dtd, each \<date\> element contains exactly one
   9 --     game. In MLB_earlylineXML.dtd, they contain multiple games.
  10 --
  11 --   * As a result of the previous difference, the \<note\>s are no
  12 --     longer in one-to-one correspondence with the games. The
  13 --     \<note\> elements are thrown in beside the \<game\>s, and we're
  14 --     supposed to figure out to which \<game\>s they correspond
  15 --     ourselves. This is the same sort of nonsense going on with
  16 --     'TSN.XML.Odds.OddsGameWithNotes'.
  17 --
  18 --    * The \<over_under\> element can be empty in
  19 --      MLB_earlylineXML.dtd (it can't in earlylineXML.dtd).
  20 --
  21 --   * Each home/away team in MLB_earlylineXML.dtd has a \<pitcher\>
  22 --     that isn't present in the regular earlylineXML.dtd.
  23 --
  24 --   * In earlylineXML.dtd, the home/away team lines are given as
  25 --     attributes on the \<teamH\> and \<teamA\> elements
  26 --     respectively. In MLB_earlylineXML.dtd, the lines can be found
  27 --     in \<line\> elements that are children of the \<teamH\> and
  28 --     \<teamA\> elements.
  29 --
  30 --   * In earlylineXML.dtd, the team names are given as text within
  31 --     the \<teamA\> and \<teamH\> elements. In MLB_earlylineXML.dtd,
  32 --     they are instead given as attributes on those respective
  33 --     elements.
  34 --
  35 --   Most of these difficulties have been worked around in
  36 --   "TSN.XML.EarlyLine", so this module could be kept somewhat boring.
  37 --
  38 module TSN.XML.MLBEarlyLine (
  39   dtd,
  40   mlb_early_line_tests,
  41   module TSN.XML.EarlyLine -- This re-exports the EarlyLine and EarlyLineGame
  42                            -- constructors unnecessarily. Whatever.
  43   )
  44 where
  45
  46 -- System imports (needed only for tests)
  47 import Database.Groundhog (
  48   countAll,
  49   deleteAll,
  50   migrate )
  51 import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
  52 import Database.Groundhog.Sqlite ( withSqliteConn )
  53 import Test.Tasty ( TestTree, testGroup )
  54 import Test.Tasty.HUnit ( (@?=), testCase )
  55
  56
  57 -- Local imports.
  58 import TSN.DbImport ( DbImport( dbimport ) )
  59 import TSN.XML.EarlyLine ( EarlyLine, EarlyLineGame, pickle_message )
  60 import Xml (
  61   pickle_unpickle,
  62   unpickleable,
  63   unsafe_unpickle )
  64
  65
  66 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  67 --
  68 dtd :: String
  69 dtd = "MLB_earlylineXML.dtd"
  70
  71
  72
  73 --
  74 -- * Tasty Tests
  75 --
  76
  77 -- | A list of all tests for this module.
  78 --
  79 mlb_early_line_tests :: TestTree
  80 mlb_early_line_tests =
  81   testGroup
  82     "MLBEarlyLine tests"
  83     [ test_on_delete_cascade,
  84       test_pickle_of_unpickle_is_identity,
  85       test_unpickle_succeeds ]
  86
  87 -- | If we unpickle something and then pickle it, we should wind up
  88 --   with the same thing we started with. WARNING: success of this
  89 --   test does not mean that unpickling succeeded.
  90 --
  91 test_pickle_of_unpickle_is_identity :: TestTree
  92 test_pickle_of_unpickle_is_identity =
  93   testCase "pickle composed with unpickle is the identity" $ do
  94     let path = "test/xml/MLB_earlylineXML.xml"
  95     (expected, actual) <- pickle_unpickle pickle_message path
  96     actual @?= expected
  97
  98
  99
 100 -- | Make sure we can actually unpickle these things.
 101 --
 102 test_unpickle_succeeds :: TestTree
 103 test_unpickle_succeeds =
 104   testCase "unpickling succeeds" $ do
 105     let path = "test/xml/MLB_earlylineXML.xml"
 106     actual <- unpickleable path pickle_message
 107
 108     let expected = True
 109     actual @?= expected
 110
 111
 112
 113 -- | Make sure everything gets deleted when we delete the top-level
 114 --   record.
 115 --
 116 test_on_delete_cascade :: TestTree
 117 test_on_delete_cascade =
 118   testCase "deleting (MLB) early_lines deletes its children" $ do
 119     let path = "test/xml/MLB_earlylineXML.xml"
 120     results <- unsafe_unpickle path pickle_message
 121     let a = undefined :: EarlyLine
 122     let b = undefined :: EarlyLineGame
 123
 124     actual <- withSqliteConn ":memory:" $ runDbConn $ do
 125                 runMigrationSilent $ do
 126                   migrate a
 127                   migrate b
 128                 _ <- dbimport results
 129                 deleteAll a
 130                 count_a <- countAll a
 131                 count_b <- countAll b
 132                 return $ sum [count_a, count_b]
 133     let expected = 0
 134     actual @?= expected