AutoRacingResults.hs

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

-- | Parse TSN XML for the DTD \"AutoRacingResultsXML.dtd\". Each
--   \<message\> element contains a \<Race_Information\> and a bunch of
--   \<Listing\>s.
--
module TSN.XML.AutoRacingResults (
  dtd,
  pickle_message,
  -- * Tests
  auto_racing_results_tests,
  -- * WARNING: these are private but exported to silence warnings
  AutoRacingResultsConstructor(..),
  AutoRacingResultsListingConstructor(..),
  AutoRacingResultsRaceInformationConstructor(..) )
where

-- System imports.
import Control.Monad ( forM_ )
import Data.Data ( Data )
import Data.Maybe ( fromMaybe )
import Data.Time ( UTCTime(..) )
import Data.Tuple.Curry ( uncurryN )
import Data.Typeable ( Typeable )
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,
  xp11Tuple,
  xp13Tuple,
  xpAttr,
  xpDefault,
  xpElem,
  xpInt,
  xpList,
  xpOption,
  xpPair,
  xpPrim,
  xpText,
  xpTriple,
  xpWrap )

-- Local imports.
import TSN.Codegen ( tsn_codegen_config )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
import TSN.Picklers (
  xp_earnings,
  xp_fracpart_only_double,
  xp_datetime,
  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 = "AutoRacingResultsXML.dtd"

--
-- DB/XML data types
--

-- * AutoRacingResults/Message

-- | Database representation of a 'Message'. Comparatively, it lacks
--   the listings and race information since they are linked via a
--   foreign key.
--
data AutoRacingResults =
  AutoRacingResults {
    db_xml_file_id :: Int,
    db_heading :: String,
    db_category :: String,
    db_sport :: String,
    db_race_id :: Int,
    db_race_date :: UTCTime,
    db_title :: String,
    db_track_location :: String,
    db_laps_remaining :: Int,
    db_checkered_flag :: Bool,
    db_time_stamp :: UTCTime }
  deriving (Eq, Show)



-- | XML Representation of an 'AutoRacingResults'. It has the same
--   fields, but in addition contains the 'xml_listings' and
--   'xml_race_information'.
--
data Message =
  Message {
    xml_xml_file_id :: Int,
    xml_heading :: String,
    xml_category :: String,
    xml_sport :: String,
    xml_race_id :: Int,
    xml_race_date :: UTCTime,
    xml_title :: String,
    xml_track_location :: String,
    xml_laps_remaining :: Int,
    xml_checkered_flag :: Bool,
    xml_listings :: [AutoRacingResultsListingXml],
    xml_race_information :: AutoRacingResultsRaceInformationXml,
    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 'AutoRacingResults'.
  --
  type Db Message = AutoRacingResults


-- | The 'FromXml' instance for 'Message' is required for the
--   'XmlImport' instance.
--
instance FromXml Message where
  -- | To convert a 'Message' to an 'AutoRacingResults', we just drop
  --   the 'xml_listings' and 'xml_race_information'.
  --
  from_xml Message{..} =
    AutoRacingResults {
      db_xml_file_id = xml_xml_file_id,
      db_heading = xml_heading,
      db_category = xml_category,
      db_sport = xml_sport,
      db_race_id = xml_race_id,
      db_race_date = xml_race_date,
      db_title = xml_title,
      db_track_location = xml_track_location,
      db_laps_remaining = xml_laps_remaining,
      db_checkered_flag = xml_checkered_flag,
      db_time_stamp = xml_time_stamp }


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


-- * AutoRacingResultsListing/AutoRacingResultsListingXml

-- | Database representation of a \<Listing\> contained within a
--   \<message\>. The leading underscores prevent unused field
--   warnings.
--
data AutoRacingResultsListing =
  AutoRacingResultsListing {
    _db_auto_racing_results_id :: DefaultKey AutoRacingResults,
    _db_finish_position :: Int,
    _db_starting_position :: Int,
    _db_car_number :: Int,
    _db_driver_id :: Int,
    _db_driver :: String,
    _db_car_make :: String,
    _db_points :: Int,
    _db_laps_completed :: Int,
    _db_laps_leading :: Int,
    _db_status :: Maybe String,
    _db_dnf :: Maybe Bool,
    _db_nc :: Maybe Bool,
    _db_earnings :: Maybe Int }
  deriving ( GHC.Generic )

-- | For 'H.convert' and 'H.cons'.
--
instance H.HVector AutoRacingResultsListing

-- | XML representation of a \<Listing\> contained within a
--   \<message\>. The leading underscores prevent unused field
--   warnings.
--
data AutoRacingResultsListingXml =
  AutoRacingResultsListingXml {
    _xml_finish_position :: Int,
    _xml_starting_position :: Int,
    _xml_car_number :: Int,
    _xml_driver_id :: Int,
    _xml_driver :: String,
    _xml_car_make :: String,
    _xml_points :: Int,
    _xml_laps_completed :: Int,
    _xml_laps_leading :: Int,
    _xml_status :: Maybe String,
    _xml_dnf :: Maybe Bool,
    _xml_nc :: Maybe Bool,
    _xml_earnings :: Maybe Int }
  deriving (Eq, GHC.Generic, Show)

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

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


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


instance FromXmlFk AutoRacingResultsListingXml where
  -- | To convert an 'AutoRacingResultsListingXml' to an
  --   'AutoRacingResultsListing', we add the foreign key and copy
  --   everything else verbatim.
  --
  from_xml_fk = H.cons


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



-- * AutoRacingResultsRaceInformation / AutoRacingResultsRaceInformationXml

-- | The \<Most_Laps_Leading\> child of \<Race_Information\> always
--   contains exactly three fields, so we just embed those three into
--   the 'AutoRacingResultsRaceInformation' type. We (pointlessly) use
--   the \"db_\" prefix since our field namer is going to strip of
--   everything before the first underscore.
--
--   We make the three fields optional because the entire
--   \<Most_Laps_Leading\> is apparently optional (although it is
--   usually present). A 'Nothing' in the XML should get turned into
--   three 'Nothing's in the DB.
--
data MostLapsLeading =
  MostLapsLeading {
    db_most_laps_leading_driver_id :: Maybe Int,
    db_most_laps_leading_driver :: Maybe String,
    db_most_laps_leading_number_of_laps :: Maybe Int }
  deriving (Data, Eq, Show, Typeable)


-- | Database representation of a \<Race_Information\> contained
--   within a \<message\>.
--
--   The 'db_most_laps_leading' field is not optional because when we
--   convert from our XML representation, a missing 'MostLapsLeading'
--   will be replaced with a 'MostLapsLeading' with three missing
--   fields.
--
data AutoRacingResultsRaceInformation =
  AutoRacingResultsRaceInformation {
    -- Note the apostrophe to disambiguate it from the
    -- AutoRacingResultsListing field.
    db_auto_racing_results_id' :: DefaultKey AutoRacingResults,
    db_track_length :: String, -- ^ Usually a Double, but sometimes a String,
                               --   like \"1.25 miles\".
    db_track_length_kph :: Double,
    db_laps :: Int,
    db_average_speed_mph :: Maybe Double,
    db_average_speed_kph :: Maybe Double,
    db_average_speed :: Maybe Double,
    db_time_of_race :: Maybe String,
    db_margin_of_victory :: Maybe String,
    db_cautions :: Maybe String,
    db_lead_changes :: Maybe String,
    db_lap_leaders :: Maybe String,
    db_most_laps_leading :: MostLapsLeading }


-- | XML representation of a \<Listing\> contained within a
--   \<message\>.
--
data AutoRacingResultsRaceInformationXml =
  AutoRacingResultsRaceInformationXml {
    xml_track_length :: String,
    xml_track_length_kph :: Double,
    xml_laps :: Int,
    xml_average_speed_mph :: Maybe Double,
    xml_average_speed_kph :: Maybe Double,
    xml_average_speed :: Maybe Double,
    xml_time_of_race :: Maybe String,
    xml_margin_of_victory :: Maybe String,
    xml_cautions :: Maybe String,
    xml_lead_changes :: Maybe String,
    xml_lap_leaders :: Maybe String,
    xml_most_laps_leading :: Maybe MostLapsLeading }
  deriving (Eq, Show)


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


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


instance FromXmlFk AutoRacingResultsRaceInformationXml where
  -- | To convert an 'AutoRacingResultsRaceInformationXml' to an
  --   'AutoRacingResultsRaceInformartion', we add the foreign key and
  --   massage the 'MostLapsLeading' embedded type,
  --
  from_xml_fk fk AutoRacingResultsRaceInformationXml{..} =
    AutoRacingResultsRaceInformation {
      db_auto_racing_results_id' = fk,
      db_track_length = xml_track_length,
      db_track_length_kph = xml_track_length_kph,
      db_laps = xml_laps,
      db_average_speed_mph = xml_average_speed_mph,
      db_average_speed_kph = xml_average_speed_kph,
      db_average_speed = xml_average_speed,
      db_time_of_race = xml_time_of_race,
      db_margin_of_victory = xml_margin_of_victory,
      db_cautions = xml_cautions,
      db_lead_changes = xml_lead_changes,
      db_lap_leaders = xml_lap_leaders,
      db_most_laps_leading = most_laps_leading }
    where
      -- If we didn't get a \<Most_Laps_Leading\>, indicate that in
      -- the database with an (embedded) 'MostLapsLeading' with three
      -- missing fields.
      most_laps_leading =
        fromMaybe (MostLapsLeading Nothing Nothing Nothing)
                  xml_most_laps_leading


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



--
-- * Database stuff.
--

instance DbImport Message where
  dbmigrate _ =
    run_dbmigrate $ do
      migrate (undefined :: AutoRacingResults)
      migrate (undefined :: AutoRacingResultsListing)
      migrate (undefined :: AutoRacingResultsRaceInformation)

  -- | We insert the message, then use its ID to insert the listings
  --   and race information.
  dbimport m = do
    msg_id <- insert_xml m

    insert_xml_fk_ msg_id (xml_race_information m)

    forM_ (xml_listings m) $ insert_xml_fk_ msg_id

    return ImportSucceeded



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


- entity: AutoRacingResultsListing
  dbName: auto_racing_results_listings
  constructors:
    - name: AutoRacingResultsListing
      fields:
        - name: _db_auto_racing_results_id
          reference:
            onDelete: cascade

  # Note the apostrophe in the foreign key. This is to disambiguate
  # it from the AutoRacingResultsListing foreign key of the same name.
  # We strip it out of the dbName.
- entity: AutoRacingResultsRaceInformation
  dbName: auto_racing_results_race_information
  constructors:
    - name: AutoRacingResultsRaceInformation
      fields:
        - name: db_auto_racing_results_id'
          dbName: auto_racing_results_id
          reference:
            onDelete: cascade
        - name: db_most_laps_leading
          embeddedType:
            - {name: most_laps_leading_driver_id,
               dbName: most_laps_leading_driver_id}
            - {name: most_laps_leading_driver,
               dbName: most_laps_leading_driver}

- embedded: MostLapsLeading
  fields:
    - name: db_most_laps_leading_driver_id
      dbName: most_laps_leading_driver_id
    - name: db_most_laps_leading_driver
      dbName: most_laps_leading_driver
    - name: db_most_laps_leading_number_of_laps
      dbName: most_laps_leading_number_of_laps
|]


---
--- Pickling
---

-- | Pickler for the \<Listing\>s contained within \<message\>s.
--
pickle_listing :: PU AutoRacingResultsListingXml
pickle_listing =
  xpElem "Listing" $
    xpWrap (from_tuple, H.convert) $
    xp13Tuple (xpElem "FinishPosition" xpInt)
              (xpElem "StartingPosition" xpInt)
              (xpElem "CarNumber" xpInt)
              (xpElem "DriverID" xpInt)
              (xpElem "Driver" xpText)
              (xpElem "CarMake" xpText)
              (xpElem "Points" xpInt)
              (xpElem "Laps_Completed" xpInt)
              (xpElem "Laps_Leading" xpInt)
              (xpElem "Status" $ xpOption xpText)
              (xpOption $ xpElem "DNF" xpPrim)
              (xpOption $ xpElem "NC" xpPrim)
              (xpElem "Earnings" xp_earnings)
  where
    from_tuple = uncurryN AutoRacingResultsListingXml


-- | Pickler for the top-level 'Message'.
--
pickle_message :: PU Message
pickle_message =
  xpElem "message" $
    xpWrap (from_tuple, H.convert) $
    xp13Tuple (xpElem "XML_File_ID" xpInt)
              (xpElem "heading" xpText)
              (xpElem "category" xpText)
              (xpElem "sport" xpText)
              (xpElem "RaceID" xpInt)
              (xpElem "RaceDate" xp_datetime)
              (xpElem "Title" xpText)
              (xpElem "Track_Location" xpText)
              (xpElem "Laps_Remaining" xpInt)
              (xpElem "Checkered_Flag" xpPrim)
              (xpList pickle_listing)
              pickle_race_information
              (xpElem "time_stamp" xp_time_stamp)
  where
    from_tuple = uncurryN Message


-- | Pickler for the \<Most_Laps_Leading\> child of a
--   \<Race_Information\>. This is complicated by the fact that the
--   three fields we're trying to parse are not actually optional;
--   only the entire \<Most_Laps_Leading\> is. So we always wrap what
--   we parse in a 'Just', and when converting from the DB to XML,
--   we'll drop the entire element if any of its fields are missing
--   (which they never should be).
--
pickle_most_laps_leading :: PU (Maybe MostLapsLeading)
pickle_most_laps_leading =
  xpElem "Most_Laps_Leading" $
    xpWrap (from_tuple, to_tuple') $
    xpTriple (xpOption $ xpElem "DriverID" xpInt)
             (xpOption $ xpElem "Driver" xpText)
             (xpOption $ xpElem "NumberOfLaps" xpInt)
  where
    from_tuple :: (Maybe Int, Maybe String, Maybe Int) -> Maybe MostLapsLeading
    from_tuple (Just x, Just y, Just z) =
      Just $ MostLapsLeading (Just x) (Just y) (Just z)
    from_tuple _ = Nothing

    -- Sure had to go out of my way to avoid the warnings about unused
    -- db_most_laps_foo fields here.
    to_tuple' :: Maybe MostLapsLeading -> (Maybe Int, Maybe String, Maybe Int)
    to_tuple' Nothing = (Nothing, Nothing, Nothing)
    to_tuple' (Just (MostLapsLeading Nothing _ _)) = (Nothing, Nothing, Nothing)
    to_tuple' (Just (MostLapsLeading _ Nothing _)) = (Nothing, Nothing, Nothing)
    to_tuple' (Just (MostLapsLeading _ _ Nothing)) = (Nothing, Nothing, Nothing)
    to_tuple' (Just m) = (db_most_laps_leading_driver_id m,
                          db_most_laps_leading_driver m,
                          db_most_laps_leading_number_of_laps m)


-- | Pickler for the \<Race_Information\> child of \<message\>.
--
--   There's so much voodoo going on here. We have a double-layered
--   Maybe on top of the MostLapsLeading. When unpickling, we return a
--   Nothing (i.e. a Maybe MostLapsLeading) if any of its fields are
--   missing. But if the entire element is missing, unpickling
--   fails. 'xpOption' doesn't fix this because it would give us a
--   Maybe (Maybe MostLapsLeading). But we can use 'xpDefault' with a
--   default of (Nothing :: Maybe MostLapsLeading) to stick one in
--   there if unpicking a (Maybe MostLapsLeading) fails because
--   \<Most_Laps_Leading\> is missing.
--
--   Clear as mud, I know.
--
pickle_race_information :: PU AutoRacingResultsRaceInformationXml
pickle_race_information =
  xpElem "Race_Information" $
    xpWrap (from_tuple, to_tuple') $
    xp11Tuple (-- I can't think of another way to get both the
               -- TrackLength and its KPH attribute. So we shove them
               -- both in a 2-tuple. This should probably be an embedded type!
                 xpElem "TrackLength" $
                   xpPair xpText
                          (xpAttr "KPH" xp_fracpart_only_double) )
              (xpElem "Laps" xpInt)
              (xpOption $ xpElem "AverageSpeedMPH" xpPrim)
              (xpOption $ xpElem "AverageSpeedKPH" xpPrim)
              (xpOption $ xpElem "AverageSpeed" xpPrim)
              (xpOption $ xpElem "TimeOfRace" xpText)
              (xpOption $ xpElem "MarginOfVictory" xpText)
              (xpOption $ xpElem "Cautions" xpText)
              (xpOption $ xpElem "LeadChanges" xpText)
              (xpOption $ xpElem "LapLeaders" xpText)
              (xpDefault Nothing pickle_most_laps_leading)
  where
    -- Derp. Since the first two are paired, we have to
    -- manually unpack the bazillion arguments.
    from_tuple ((x1,x2),x3,x4,x5,x6,x7,x8,x9,x10,x11,x12) =
        AutoRacingResultsRaceInformationXml
          x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12

    -- And here we have to re-pair the first two.
    to_tuple' m = ((xml_track_length m, xml_track_length_kph m),
                   xml_laps m,
                   xml_average_speed_mph m,
                   xml_average_speed_kph m,
                   xml_average_speed m,
                   xml_time_of_race m,
                   xml_margin_of_victory m,
                   xml_cautions m,
                   xml_lead_changes m,
                   xml_lap_leaders m,
                   xml_most_laps_leading m)

--
-- * Tasty Tests
--

-- | A list of all tests for this module.
--
auto_racing_results_tests :: TestTree
auto_racing_results_tests =
  testGroup
    "AutoRacingResults 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/AutoRacingResultsXML.xml",

    check "pickle composed with unpickle is the identity (fractional KPH)"
          "test/xml/AutoRacingResultsXML-fractional-kph.xml",

    check "pickle composed with unpickle is the identity (No Most_Laps_Leading)"
          "test/xml/AutoRacingResultsXML-no-most-laps-leading.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/AutoRacingResultsXML.xml",

    check "unpickling succeeds (fractional KPH)"
          "test/xml/AutoRacingResultsXML-fractional-kph.xml",

    check "unpickling succeeds (no Most_Laps_Leading)"
          "test/xml/AutoRacingResultsXML-no-most-laps-leading.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_results deletes its children"
          "test/xml/AutoRacingResultsXML.xml",

    check "deleting auto_racing_results deletes its children (fractional KPH)"
          "test/xml/AutoRacingResultsXML-fractional-kph.xml",

    check ("deleting auto_racing_results deletes its children " ++
           "(No Most_Laps_Leading)")
          "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ]
  where
    check desc path = testCase desc $ do
      results <- unsafe_unpickle path pickle_message
      let a = undefined :: AutoRacingResults
      let b = undefined :: AutoRacingResultsListing
      let c = undefined :: AutoRacingResultsRaceInformation

      actual <- withSqliteConn ":memory:" $ runDbConn $ do
                  runMigrationSilent $ do
                    migrate a
                    migrate b
                    migrate c
                  _ <- dbimport results
                  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