AutoRacingDriverList.hs

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


-- | Parse TSN XML for the DTD \"AutoRacingDriverList.dtd\". Each
--   \<message\> element contains a bunch of \<Listing\>s, each of
--   which describes a driver/car.
--
module TSN.XML.AutoRacingDriverList (
  dtd,
  pickle_message,
  -- * Tests
  auto_racing_driver_list_tests,
  -- * WARNING: these are private but exported to silence warnings
  AutoRacingDriverListConstructor(..),
  AutoRacingDriverListListingConstructor(..) )
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,
  xp9Tuple,
  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, 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 = "AutoRacingDriverList.dtd"

--
-- * DB/XML data types
--

-- AutoRacingDriverList/Message

-- | Database representation of a 'Message'. Comparatively, it lacks
--   only the listings.
--
data AutoRacingDriverList =
  AutoRacingDriverList {
    db_xml_file_id :: Int,
    db_heading :: String,
    db_category :: String,
    db_sport :: String,
    db_title :: String,
    db_time_stamp :: UTCTime }
  deriving (Eq, Show)



-- | XML Representation of an 'AutoRacingDriverList'. It has the same
--   fields, but in addition contains the 'xml_listings'.
--
data Message =
  Message {
    xml_xml_file_id :: Int,
    xml_heading :: String,
    xml_category :: String,
    xml_sport :: String,
    xml_title :: String,
    xml_listings :: [AutoRacingDriverListListingXml],
    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 'AutoRacingDriverList'.
  --
  type Db Message = AutoRacingDriverList


-- | The 'FromXml' instance for 'Message' is required for the
--   'XmlImport' instance.
--
instance FromXml Message where
  -- | To convert a 'Message' to an 'AutoRacingDriverList', we just drop
  --   the 'xml_listings'.
  --
  from_xml Message{..} =
    AutoRacingDriverList {
      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_time_stamp = xml_time_stamp }


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


-- AutoRacingDriverListListing / AutoRacingDriverListListingXml

-- | Database representation of a \<Listing\> contained within a
--   \<message\>. The leading underscores prevent unused field
--   warnings.
--
data AutoRacingDriverListListing =
  AutoRacingDriverListListing {
    _db_auto_racing_driver_lists_id :: DefaultKey AutoRacingDriverList,
    _db_driver_id :: Int,
    _db_driver :: String,
    _db_height :: Maybe String,
    _db_weight :: Int,
    _db_date_of_birth :: UTCTime,
    _db_hometown :: String,
    _db_nationality :: Maybe String,
    _db_car_number :: Int,
    _db_car :: String }
  deriving ( GHC.Generic )

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


-- | XML representation of a \<Listing\> contained within a
--   \<message\>. The underscores prevent unused field warnings.
--
data AutoRacingDriverListListingXml =
  AutoRacingDriverListListingXml {
    _xml_driver_id :: Int,
    _xml_driver :: String,
    _xml_height :: Maybe String,
    _xml_weight :: Int,
    _xml_date_of_birth :: UTCTime,
    _xml_hometown :: String,
    _xml_nationality :: Maybe String,
    _xml_car_number :: Int,
    _xml_car :: String }
  deriving (Eq, GHC.Generic, Show)

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

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


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


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



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



--
-- * Database
--

instance DbImport Message where
  dbmigrate _ =
    run_dbmigrate $ do
      migrate (undefined :: AutoRacingDriverList)
      migrate (undefined :: AutoRacingDriverListListing)

  -- | We insert the message, then use its ID to insert the listings.
  dbimport m = do
    msg_id <- insert_xml m
    forM_ (xml_listings m) $ insert_xml_fk_ msg_id

    return ImportSucceeded



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


- entity: AutoRacingDriverListListing
  dbName: auto_racing_driver_lists_listings
  constructors:
    - name: AutoRacingDriverListListing
      fields:
        - name: _db_auto_racing_driver_lists_id
          reference:
            onDelete: cascade

|]


--
-- * Pickling
--

-- | Pickler for the \<Listing\>s contained within \<message\>s.
--
pickle_listing :: PU AutoRacingDriverListListingXml
pickle_listing =
  xpElem "Listing" $
    xpWrap (from_tuple, H.convert) $
    xp9Tuple (xpElem "DriverID" xpInt)
             (xpElem "Driver" xpText)
             (xpElem "Height" $ xpOption xpText)
             (xpElem "Weight" xpInt)
             (xpElem "DOB" xp_date)
             (xpElem "Hometown" xpText)
             (xpElem "Nationality" $ xpOption xpText)
             (xpElem "Car_Number" xpInt)
             (xpElem "Car" xpText)
  where
    from_tuple = uncurryN AutoRacingDriverListListingXml

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



--
-- * Tasty Tests
--

-- | A list of all tests for this module.
--
auto_racing_driver_list_tests :: TestTree
auto_racing_driver_list_tests =
  testGroup
    "AutoRacingDriverList 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/AutoRacingDriverList.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/AutoRacingDriverList.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_driver_lists deletes its children"
          "test/xml/AutoRacingDriverList.xml" ]
  where
    check desc path = testCase desc $ do
      results <- unsafe_unpickle path pickle_message
      let a = undefined :: AutoRacingDriverList
      let b = undefined :: AutoRacingDriverListListing

      actual <- withSqliteConn ":memory:" $ runDbConn $ do
                  runMigrationSilent $ 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