AutoRacingSchedule.hs

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

-- | Parse TSN XML for the DTD
--   \"Auto_Racing_Schedule_XML.dtd\". There's a top-level
--   \<message\>, containing \<Listing\>s, containing \<RaceResults\>,
--   containing \<RaceResultsListing\>s.
--
module TSN.XML.AutoRacingSchedule (
  dtd,
  pickle_message,
  -- * Tests
  auto_racing_schedule_tests,
  -- * WARNING: these are private but exported to silence warnings
  AutoRacingScheduleConstructor(..),
  AutoRacingScheduleListingConstructor(..),
  AutoRacingScheduleListingRaceResultRaceResultListingConstructor(..) )
where

-- System imports.
import Control.Monad ( forM_ )
import Data.Time ( UTCTime(..) )
import Data.Tuple.Curry ( uncurryN )
import qualified Data.Vector.HFixed as H ( HVector, cons, convert )
import Database.Groundhog (
  countAll,
  deleteAll,
  migrate )
import Database.Groundhog.Core ( DefaultKey )
import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
import Database.Groundhog.Sqlite ( withSqliteConn )
import Database.Groundhog.TH (
  groundhog,
  mkPersist )
import qualified GHC.Generics as GHC ( Generic )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
  PU,
  xp7Tuple,
  xp8Tuple,
  xp10Tuple,
  xpElem,
  xpInt,
  xpList,
  xpOption,
  xpText,
  xpWrap )

-- Local imports.
import TSN.Codegen (
  tsn_codegen_config )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
import TSN.Picklers ( xp_date_padded, xp_tba_time, xp_time_stamp )
import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
import Xml (
  Child(..),
  FromXml(..),
  FromXmlFk(..),
  ToDb(..),
  pickle_unpickle,
  unpickleable,
  unsafe_unpickle )


-- | The DTD to which this module corresponds. Used to invoke dbimport.
--
dtd :: String
dtd = "Auto_Racing_Schedule_XML.dtd"

--
-- DB/XML data types
--

-- * AutoRacingSchedule/Message

-- | Database representation of a 'Message'.
--
data AutoRacingSchedule =
  AutoRacingSchedule {
    db_xml_file_id :: Int,
    db_heading :: String,
    db_category :: String,
    db_sport :: String,
    db_title :: String,
    db_complete_through :: String,
    db_time_stamp :: UTCTime }
  deriving (Eq, Show)


-- | XML Representation of an 'AutoRacingSchedule'.
--
data Message =
  Message {
    xml_xml_file_id :: Int,
    xml_heading :: String,
    xml_category :: String,
    xml_sport :: String,
    xml_title :: String,
    xml_complete_through :: String,
    xml_listings :: [AutoRacingScheduleListingXml],
    xml_time_stamp :: UTCTime }
  deriving (Eq, GHC.Generic, Show)

-- | For 'H.convert'.
--
instance H.HVector Message


instance ToDb Message where
  -- | The database analogue of a 'Message' is a 'AutoRacingSchedule'.
  --
  type Db Message = AutoRacingSchedule


-- | The 'FromXml' instance for 'Message' is required for the
--   'XmlImport' instance.
--
instance FromXml Message where
  -- | To convert a 'Message' to an 'AutoRacingSchedule', we just drop
  --   the 'xml_listings'.
  --
  from_xml Message{..} =
    AutoRacingSchedule {
      db_xml_file_id = xml_xml_file_id,
      db_heading = xml_heading,
      db_category = xml_category,
      db_sport = xml_sport,
      db_title = xml_title,
      db_complete_through = xml_complete_through,
      db_time_stamp = xml_time_stamp }


-- | This allows us to insert the XML representation 'Message'
--   directly.
--
instance XmlImport Message


-- * AutoRacingScheduleListing/AutoRacingScheduleListingXml

-- | Database representation of a \<Listing\> contained within a
--   \<message\>. We combine the race date/time into a single
--   race_time, drop the race results list, and add a foreign key to
--   our parent.
--
data AutoRacingScheduleListing =
  AutoRacingScheduleListing {
    db_auto_racing_schedules_id :: DefaultKey AutoRacingSchedule,
    db_race_id :: Int,
    db_race_time :: UTCTime,
    db_race_name :: String,
    db_track_name :: String,
    db_location :: String,
    db_tv_listing :: Maybe String,
    db_laps :: Int,
    db_track_length :: String -- ^ Sometimes the word "miles" shows up.
  }


-- | XML representation of a \<Listing\> contained within a
--   \<message\>.
--
data AutoRacingScheduleListingXml =
  AutoRacingScheduleListingXml {
    xml_race_id :: Int,
    xml_race_date :: UTCTime,
    xml_race_time :: Maybe UTCTime,
    xml_race_name :: String,
    xml_track_name :: String,
    xml_location :: String,
    xml_tv_listing :: Maybe String,
    xml_laps :: Int,
    xml_track_length :: String, -- ^ Sometimes the word \"miles\" shows up,
                                --   so we can't do the right thing and use
                                --   a 'Double'.
    xml_race_results :: [AutoRacingScheduleListingRaceResult] }
  deriving (Eq, GHC.Generic, Show)

-- | For 'H.convert'.
--
instance H.HVector AutoRacingScheduleListingXml


-- | Pseudo-accessor to get the race result listings out of a
--   'AutoRacingScheduleListingXml'. A poor man's lens.
--
result_listings :: AutoRacingScheduleListingXml
                -> [AutoRacingScheduleListingRaceResultRaceResultListingXml]
result_listings = (concatMap xml_race_result_listing) . xml_race_results


instance ToDb AutoRacingScheduleListingXml where
  -- | The database analogue of an 'AutoRacingScheduleListingXml' is
  --   an 'AutoRacingScheduleListing'.
  --
  type Db AutoRacingScheduleListingXml = AutoRacingScheduleListing


instance Child AutoRacingScheduleListingXml where
  -- | Each 'AutoRacingScheduleListingXml' is contained in (i.e. has a
  --   foreign key to) a 'AutoRacingSchedule'.
  --
  type Parent AutoRacingScheduleListingXml = AutoRacingSchedule


instance FromXmlFk AutoRacingScheduleListingXml where
  -- | To convert an 'AutoRacingScheduleListingXml' to an
  --   'AutoRacingScheduleListing', we add the foreign key and drop
  --   the 'xml_race_results'. We also mash the date/time together
  --   into one field.
  --
  from_xml_fk fk AutoRacingScheduleListingXml{..} =
    AutoRacingScheduleListing {
      db_auto_racing_schedules_id = fk,
      db_race_id = xml_race_id,
      db_race_time = make_race_time xml_race_date xml_race_time,
      db_race_name = xml_race_name,
      db_track_name = xml_track_name,
      db_location = xml_location,
      db_tv_listing = xml_tv_listing,
      db_laps = xml_laps,
      db_track_length = xml_track_length }
    where
      -- | Make the database \"race time\" from the XML
      --   date/time. Simply take the day part from one and the time
      --   from the other.
      --
      make_race_time d Nothing = d
      make_race_time d (Just t) = UTCTime (utctDay d) (utctDayTime t)


-- | This allows us to insert the XML representation
--   'AutoRacingScheduleListingXml' directly.
--
instance XmlImportFk AutoRacingScheduleListingXml



-- * AutoRacingScheduleListingRaceResult

-- | The XML representation of \<message\> -> \<Listing\> ->
--   \<RaceResults\>. This element serves only to contain
--   \<RaceResultsListing\>s, so we don't store the intermediate table
--   in the database.
--
newtype AutoRacingScheduleListingRaceResult =
  AutoRacingScheduleListingRaceResult {
    xml_race_result_listing ::
      [AutoRacingScheduleListingRaceResultRaceResultListingXml] }
  deriving (Eq, Show)


-- * AutoRacingScheduleListingRaceResultRaceResultListing / AutoRacingScheduleListingRaceResultRaceResultListingXml
--
--   Sorry about the names yo.
--

-- | Database representation of \<RaceResultListing\> within
--   \<RaceResults\> within \<Listing\> within... \<message\>!
--   The leading underscores prevent unused field warnings.
--
data AutoRacingScheduleListingRaceResultRaceResultListing =
  AutoRacingScheduleListingRaceResultRaceResultListing {
    _db_auto_racing_schedules_listings_id ::
      DefaultKey AutoRacingScheduleListing,
    _db_finish_position :: Int,
    _db_driver_id :: Int,
    _db_name :: String,
    _db_leading_laps :: Int,
    _db_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field.
    _db_earnings :: String,  -- ^ This should be an Int, but can have commas.
    _db_status :: Maybe String -- ^ They can be empty
    }
  deriving ( GHC.Generic )

-- | For 'H.cons'.
--
instance H.HVector AutoRacingScheduleListingRaceResultRaceResultListing


-- | XML Representation of an
--   'AutoRacingScheduleListingRaceResultRaceResultListing'.
--   The leading underscores prevent unused field warnings.
--
data AutoRacingScheduleListingRaceResultRaceResultListingXml =
  AutoRacingScheduleListingRaceResultRaceResultListingXml {
    _xml_finish_position :: Int,
    _xml_driver_id :: Int,
    _xml_name :: String,
    _xml_leading_laps :: Int,
    _xml_listing_laps :: Int, -- ^ Avoids clash with race's \"laps\" field.
    _xml_earnings :: String,  -- ^ Should be an 'Int', but can have commas.
    _xml_status :: Maybe String -- ^ They can be empty
    }
  deriving (Eq, GHC.Generic, Show)

-- | For 'H.convert'.
--
instance H.HVector AutoRacingScheduleListingRaceResultRaceResultListingXml


instance ToDb AutoRacingScheduleListingRaceResultRaceResultListingXml where
  -- | The database representation of an
  --   'AutoRacingScheduleListingRaceResultRaceResultListingXml' is an
  --   'AutoRacingScheduleListingRaceResultRaceResultListing'.
  --
  type Db AutoRacingScheduleListingRaceResultRaceResultListingXml =
    AutoRacingScheduleListingRaceResultRaceResultListing


instance Child AutoRacingScheduleListingRaceResultRaceResultListingXml where
  -- | Each 'AutoRacingScheduleListingRaceResultRaceResultListingXml'
  --   is contained in (i.e. has a foreign key to) an
  --   'AutoRacingScheduleListing'. We skip the intermediate
  --   \<RaceResults\>.
  --
  type Parent AutoRacingScheduleListingRaceResultRaceResultListingXml =
    AutoRacingScheduleListing


instance FromXmlFk AutoRacingScheduleListingRaceResultRaceResultListingXml where
  -- | To convert an
  --   'AutoRacingScheduleListingRaceResultRaceResultListingXml' to an
  --   'AutoRacingScheduleListingRaceResultRaceResultListing', we just
  --   add the foreign key to the parent 'AutoRacingScheduleListing'.
  --
  from_xml_fk = H.cons


-- | This allows us to insert the XML representation
--   'AutoRacingScheduleListingRaceResultRaceResultListingXml'
--   directly.
--
instance XmlImportFk AutoRacingScheduleListingRaceResultRaceResultListingXml


---
--- Database stuff.
---

instance DbImport Message where
  dbmigrate _ =
    run_dbmigrate $ do
      migrate (undefined :: AutoRacingSchedule)
      migrate (undefined :: AutoRacingScheduleListing)
      migrate (undefined
                 :: AutoRacingScheduleListingRaceResultRaceResultListing)


  -- | We insert the message, then use its ID to insert the listings,
  --   using their IDs to insert the race result listings.
  --
  dbimport m = do
    msg_id <- insert_xml m

    forM_ (xml_listings m) $ \listing -> do
      listing_id <- insert_xml_fk msg_id listing

      mapM_ (insert_xml_fk_ listing_id) (result_listings listing)

    return ImportSucceeded


mkPersist tsn_codegen_config [groundhog|
- entity: AutoRacingSchedule
  dbName: auto_racing_schedules
  constructors:
    - name: AutoRacingSchedule
      uniques:
        - name: unique_auto_racing_schedules
          type: constraint
          # Prevent multiple imports of the same message.
          fields: [db_xml_file_id]

- entity: AutoRacingScheduleListing
  dbName: auto_racing_schedules_listings
  constructors:
    - name: AutoRacingScheduleListing
      fields:
        - name: db_auto_racing_schedules_id
          reference:
            onDelete: cascade

- entity: AutoRacingScheduleListingRaceResultRaceResultListing
  dbName: auto_racing_schedules_listings_race_result_listings
  constructors:
    - name: AutoRacingScheduleListingRaceResultRaceResultListing
      fields:
        - name: _db_auto_racing_schedules_listings_id
          reference:
            onDelete: cascade
|]



---
--- Pickling
---

-- | Pickler for the top-level 'Message'.
--
pickle_message :: PU Message
pickle_message =
  xpElem "message" $
    xpWrap (from_tuple, H.convert) $
    xp8Tuple (xpElem "XML_File_ID" xpInt)
             (xpElem "heading" xpText)
             (xpElem "category" xpText)
             (xpElem "sport" xpText)
             (xpElem "Title" xpText)
             (xpElem "Complete_Through" xpText)
             (xpList pickle_listing)
             (xpElem "time_stamp" xp_time_stamp)
  where
    from_tuple = uncurryN Message


-- | Convert an 'AutoRacingScheduleListingXml' to/from XML.
--
pickle_listing :: PU AutoRacingScheduleListingXml
pickle_listing =
  xpElem "Listing" $
    xpWrap (from_tuple, H.convert) $
      xp10Tuple (xpElem "RaceID" xpInt)
                (xpElem "Race_Date" xp_date_padded)
                (xpElem "Race_Time" xp_tba_time)
                (xpElem "RaceName" xpText)
                (xpElem "TrackName" xpText)
                (xpElem "Location" xpText)
                (xpElem "TV_Listing" $ xpOption xpText)
                (xpElem "Laps" xpInt)
                (xpElem "TrackLength" xpText)
                (xpList pickle_race_results)
  where
    from_tuple = uncurryN AutoRacingScheduleListingXml



-- | Convert an 'AutoRacingScheduleListingRaceResult' to/from XML.
--
pickle_race_results :: PU AutoRacingScheduleListingRaceResult
pickle_race_results =
  xpElem "RaceResults" $
    xpWrap (to_result, from_result) $
      xpList pickle_race_results_listing
  where
    to_result = AutoRacingScheduleListingRaceResult
    from_result = xml_race_result_listing


-- | Convert an
--   'AutoRacingScheduleListingRaceResultRaceResultListingXml' to/from
--   XML.
--
pickle_race_results_listing ::
  PU AutoRacingScheduleListingRaceResultRaceResultListingXml
pickle_race_results_listing =
  xpElem "RaceResultsListing" $
    xpWrap (from_tuple, H.convert) $
      xp7Tuple (xpElem "FinishPosition" xpInt)
               (xpElem "DriverID" xpInt)
               (xpElem "Name" xpText)
               (xpElem "LeadingLaps" xpInt)
               (xpElem "Laps" xpInt)
               (xpElem "Earnings" xpText)
               (xpElem "Status" (xpOption xpText))
  where
    from_tuple =
      uncurryN AutoRacingScheduleListingRaceResultRaceResultListingXml


--
-- Tasty Tests
--

-- | A list of all tests for this module.
--
auto_racing_schedule_tests :: TestTree
auto_racing_schedule_tests =
  testGroup
    "AutoRacingSchedule 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 = testGroup "pickle-unpickle tests"
  [ check "pickle composed with unpickle is the identity"
          "test/xml/Auto_Racing_Schedule_XML.xml",

    check "pickle composed with unpickle is the identity (miles track length)"
          "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
  where
    check desc path = testCase desc $ do
      (expected, actual) <- pickle_unpickle pickle_message path
      actual @?= expected


-- | Make sure we can actually unpickle these things.
--
test_unpickle_succeeds :: TestTree
test_unpickle_succeeds = testGroup "unpickle tests"
  [ check "unpickling succeeds"
          "test/xml/Auto_Racing_Schedule_XML.xml",

    check "unpickling succeeds (non-int team_id)"
          "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
  where
    check desc path = testCase desc $ do
      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 = testGroup "cascading delete tests"
    [ check "deleting auto_racing_schedules deletes its children"
          "test/xml/Auto_Racing_Schedule_XML.xml" ,

    check ("deleting auto_racing_schedules deletes its children " ++
            "(miles track length)")
          "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
  where
    check desc path = testCase desc $ do
      sched <- unsafe_unpickle path pickle_message
      let a = undefined :: AutoRacingSchedule
      let b = undefined :: AutoRacingScheduleListing
      let c = undefined :: AutoRacingScheduleListingRaceResultRaceResultListing

      actual <- withSqliteConn ":memory:" $ runDbConn $ do
                  runMigrationSilent $ do
                    migrate a
                    migrate b
                    migrate c
                  _ <- dbimport sched
                  deleteAll a
                  count_a <- countAll a
                  count_b <- countAll b
                  count_c <- countAll c
                  return $ sum [count_a, count_b, count_c]
      let expected = 0
      actual @?= expected