Scores.hs

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

-- | Parse TSN XML for the DTD \"scoresxml.dtd\". Each document
--   contains a single \<game\> and some \<location\>s.
--
module TSN.XML.Scores (
  dtd,
  pickle_message,
  -- * Tests
  scores_tests,
  -- * WARNING: these are private but exported to silence warnings
  Score_LocationConstructor(..),
  ScoreConstructor(..),
  ScoreGameConstructor(..) )
where

-- System imports.
import Control.Monad ( join )
import Data.Data ( Data )
import Data.Time ( UTCTime )
import Data.Tuple.Curry ( uncurryN )
import Data.Typeable ( Typeable )
import qualified Data.Vector.HFixed as H ( HVector, convert )
import Database.Groundhog (
  countAll,
  deleteAll,
  insert_,
  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,
  xp11Tuple,
  xpAttr,
  xpElem,
  xpInt,
  xpList,
  xpOption,
  xpPrim,
  xpText,
  xpTriple,
  xpWrap )

-- Local imports.
import Misc ( double_just )
import TSN.Codegen ( tsn_codegen_config )
import TSN.Database ( insert_or_select )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
import TSN.Location ( Location(..), pickle_location )
import TSN.Picklers ( xp_attr_option, xp_time_stamp )
import TSN.Team (
  FromXmlFkTeams(..),
  HTeam(..),
  Team(..),
  VTeam(..) )
import TSN.XmlImport ( XmlImport(..), XmlImportFkTeams(..) )
import Xml (
  Child(..),
  FromXml(..),
  ToDb(..),
  pickle_unpickle,
  unpickleable,
  unsafe_unpickle )


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


--
-- * DB/XML Data types
--


-- * Score / Message

-- | Database representation of a 'Message'. It lacks the
--   'xml_locations' and 'xml_game' which are related via foreign keys
--   instead.
--
data Score =
  Score {
    db_xml_file_id :: Int,
    db_heading :: String,
    db_game_id :: Maybe Int, -- ^ We've seen an empty one
    db_schedule_id :: Maybe Int, -- ^ We've seen an empty one
    db_tsnupdate :: Maybe Bool,
    db_category :: String,
    db_sport :: String,
    db_season_type :: Maybe String, -- ^ We've seen an empty one
    db_time_stamp :: UTCTime }


-- | XML representation of the top level \<message\> element (i.e. a
--   'Score').
--
data Message =
  Message {
    xml_xml_file_id :: Int,
    xml_heading :: String,
    xml_game_id :: Maybe Int, -- ^ We've seen an empty one
    xml_schedule_id :: Maybe Int, -- ^ We've seen an empty one
    xml_tsnupdate :: Maybe Bool,
    xml_category :: String,
    xml_sport :: String,
    xml_locations :: [Location],
    xml_season_type :: Maybe String, -- ^ We've seen an empty one
    xml_game :: ScoreGameXml,
    xml_time_stamp :: UTCTime }
  deriving (Eq, GHC.Generic, Show)


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


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

instance FromXml Message where
  -- | When converting from the XML representation to the database
  --   one, we drop the list of locations which will be foreign-keyed to
  --   us instead.
  from_xml Message{..} =
    Score {
      db_xml_file_id = xml_xml_file_id,
      db_heading = xml_heading,
      db_game_id = xml_game_id,
      db_schedule_id = xml_schedule_id,
      db_tsnupdate = xml_tsnupdate,
      db_category = xml_category,
      db_sport = xml_sport,
      db_season_type = xml_season_type,
      db_time_stamp = xml_time_stamp }


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


-- * ScoreGame / ScoreGameXml

-- | This is an embedded field within 'SportsGame'. Each \<status\>
--   element has two attributes, a numeral and a type. It also
--   contains some text. Rather than put these in their own table, we
--   include them in the parent 'SportsGame'.
--
data ScoreGameStatus =
  ScoreGameStatus {
    db_status_numeral :: Maybe Int,
    db_status_type :: Maybe String, -- ^ These are probably only one-character,
                                    --   long, but they all take the same
                                    --    amount of space in Postgres.
    db_status_text :: String }
  deriving (Data, Eq, Show, Typeable)


-- | Database representation of a game.
--
data ScoreGame =
  ScoreGame {
    db_scores_id :: DefaultKey Score,
    db_away_team_id :: DefaultKey Team,
    db_home_team_id :: DefaultKey Team,
    db_away_team_score :: Int,
    db_home_team_score :: Int,
    db_away_team_pitcher :: Maybe String, -- ^ Found in the child \<vteam\>
    db_home_team_pitcher :: Maybe String, -- ^ Found in the child \<hteam\>
    db_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
    db_status :: ScoreGameStatus,
    db_notes  :: Maybe String }


-- | XML representation of a \<game\> element (i.e. a 'ScoreGame').
--
data ScoreGameXml =
  ScoreGameXml {
    xml_vteam  :: VTeamXml,
    xml_hteam  :: HTeamXml,
    xml_away_team_score :: Int,
    xml_home_team_score :: Int,
    xml_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
    xml_status :: ScoreGameStatus,
    xml_notes  :: Maybe String }
  deriving (Eq, GHC.Generic, Show)


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


instance ToDb ScoreGameXml where
  -- | The database representation of a 'ScoreGameXml' is a
  --   'ScoreGame'.
  --
  type Db ScoreGameXml = ScoreGame


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


instance FromXmlFkTeams ScoreGameXml where
  -- | To create a 'ScoreGame' from a 'ScoreGameXml', we need three
  --   foreign keys: the parent message, and the away/home teams.
  --
  --   During conversion, we also get the pitchers out of the teams;
  --   unfortunately this prevents us from making the conversion
  --   generically.
  --
  from_xml_fk_teams fk fk_away fk_home ScoreGameXml{..} =
    ScoreGame {
      db_scores_id = fk,
      db_away_team_id = fk_away,
      db_home_team_id = fk_home,
      db_away_team_score = xml_away_team_score,
      db_home_team_score = xml_home_team_score,
      db_away_team_pitcher = xml_vpitcher xml_vteam,
      db_home_team_pitcher = xml_hpitcher xml_hteam,
      db_time_r = xml_time_r,
      db_status = xml_status,
      db_notes = xml_notes }

-- | This lets us import the database representation 'ScoreGameXml'
--   directly.
--
instance XmlImportFkTeams ScoreGameXml



-- * Score_Location

-- | Join each 'Score' with its 'Location's. Database-only. We use a
--   join table because the locations are kept unique but there are
--   multiple locations per 'Score'.
--
data Score_Location =
  Score_Location
    (DefaultKey Score)
    (DefaultKey Location)


-- * HTeamXml / VTeamXml

-- | XML Representation of a home team. This document type is unusual
--   in that the \<hteam\> elements can have a pitcher attribute
--   attached to them. We still want to maintain the underlying 'Team'
--   representation, so we say that a home team is a 'Team' and
--   (maybe) a pitcher.
--
data HTeamXml =
  HTeamXml {
    xml_ht :: HTeam,
    xml_hpitcher :: Maybe String }
  deriving (Eq, Show)

instance ToDb HTeamXml where
  -- | The database analogue of a 'HTeamXml' is its 'Team'.
  type Db HTeamXml = Team

instance FromXml HTeamXml where
  -- | The conversion from XML to database is simply the 'Team' accessor.
  --
  from_xml = hteam . xml_ht

-- | Allow import of the XML representation directly, without
--   requiring a manual conversion to the database type first.
--
instance XmlImport HTeamXml



-- | XML Representation of an away team. This document type is unusual
--   in that the \<hteam\> elements can have a pitcher attribute
--   attached to them. We still want to maintain the underlying 'Team'
--   representation, so we say that an away team is a 'Team' and
--   (maybe) a pitcher.
--
data VTeamXml =
  VTeamXml {
    xml_vt :: VTeam,
    xml_vpitcher :: Maybe String }
  deriving (Eq, Show)

instance ToDb VTeamXml where
  -- | The database analogue of a 'VTeamXml' is its 'Team'.
  type Db VTeamXml = Team

instance FromXml VTeamXml where
  -- | The conversion from XML to database is simply the 'Team' accessor.
  --
  from_xml = vteam . xml_vt

-- | Allow import of the XML representation directly, without
--   requiring a manual conversion to the database type first.
--
instance XmlImport VTeamXml



instance DbImport Message where
  dbmigrate _ =
    run_dbmigrate $ do
      migrate (undefined :: Location)
      migrate (undefined :: Team)
      migrate (undefined :: Score)
      migrate (undefined :: ScoreGame)
      migrate (undefined :: Score_Location)

  dbimport m = do
    -- Insert the message and get its ID.
    msg_id <- insert_xml m

    -- Insert all of the locations contained within this message and
    -- collect their IDs in a list. We use insert_or_select because
    -- most of the locations will already exist, and we just want to
    -- get the ID of the existing location when there's a collision.
    location_ids <- mapM insert_or_select (xml_locations m)

    -- Now use that list to construct 'Score_ScoreLocation' objects,
    -- and insert them.
    mapM_ (insert_ . Score_Location msg_id) location_ids

    -- Insert the hteam/vteams, noting the IDs.
    vteam_id <- insert_xml_or_select (xml_vteam $ xml_game m)
    hteam_id <- insert_xml_or_select (xml_hteam $ xml_game m)

    -- Now use those along with the msg_id to construct the game.
    insert_xml_fk_teams_ msg_id vteam_id hteam_id (xml_game m)

    return ImportSucceeded



-- These types have fields with e.g. db_ and xml_ prefixes, so we
-- use our own codegen to peel those off before naming the columns.
mkPersist tsn_codegen_config [groundhog|
- entity: Score
  dbName: scores
  constructors:
    - name: Score
      uniques:
        - name: unique_scores
          type: constraint
          # Prevent multiple imports of the same message.
          fields: [db_xml_file_id]

- embedded: ScoreGameStatus
  fields:
    - name: db_status_numeral
      dbName: status_numeral
    - name: db_status_type
      dbName: status_type
    - name: db_status_text
      dbName: status_text


- entity: ScoreGame
  dbName: scores_games
  constructors:
    - name: ScoreGame
      fields:
        - name: db_scores_id
          reference:
            onDelete: cascade
        - name: db_status
          embeddedType:
            - { name: status_numeral, dbName: status_numeral }
            - { name: status_type, dbName: status_type }
            - { name: status_text, dbName: status_text }


- entity: Score_Location
  dbName: scores__locations
  constructors:
    - name: Score_Location
      fields:
        - name: score_Location0 # Default created by mkNormalFieldName
          dbName: scores_id
          reference:
            onDelete: cascade
        - name: score_Location1 # Default created by mkNormalFieldName
          dbName: locations_id
          reference:
            onDelete: cascade
|]


--
-- Pickling
--

-- | Convert a 'Message' to/from \<message\>.
--
pickle_message :: PU Message
pickle_message =
  xpElem "message" $
    xpWrap (from_tuple, H.convert) $
    xp11Tuple (xpElem "XML_File_ID" xpInt)
              (xpElem "heading" xpText)
              (xpElem "game_id" (xpOption xpInt))
              (xpElem "schedule_id" (xpOption xpInt))
              (xpOption $ xpElem "tsnupdate" xpPrim)
              (xpElem "category" xpText)
              (xpElem "sport" xpText)
              (xpList pickle_location)
              (xpElem "seasontype" (xpOption xpText))
              pickle_game
              (xpElem "time_stamp" xp_time_stamp)
  where
    from_tuple = uncurryN Message



-- | Convert a 'ScoreGameStatus' to/from \<status\>. The \"type\"
--   attribute can be either missing or empty, so we're really parsing
--   a double-Maybe here. We use the monad join to collapse it into
--   one. See also: the hteam/vteam picklers.
--
pickle_status :: PU ScoreGameStatus
pickle_status =
  xpElem "status" $
    xpWrap (from_tuple, to_tuple') $
      xpTriple (xpAttr "numeral" xp_attr_option)
               (xpOption $ xpAttr "type" $ xpOption xpText)
               xpText
  where
    from_tuple (x,y,z) = ScoreGameStatus x (join y) z
    to_tuple' ScoreGameStatus{..} =
      (db_status_numeral, double_just db_status_type, db_status_text)


-- | Convert a 'ScoreGameXml' to/from \<game\>.
--
pickle_game :: PU ScoreGameXml
pickle_game =
  xpElem "game" $
    xpWrap (from_tuple, H.convert) $
      xp7Tuple pickle_vteam
               pickle_hteam
               (xpElem "vscore" xpInt)
               (xpElem "hscore" xpInt)
               (xpOption $ xpElem "time_r" xpText)
               pickle_status
               (xpOption $ xpElem "notes" xpText)
  where
    from_tuple = uncurryN ScoreGameXml


-- | Convert a 'VTeamXml' to/from \<vteam\>. The team names
--   always seem to be present here, but in the shared representation,
--   they're optional (because they show up blank elsewhere). So, we
--   pretend they're optional.
--
--   The \"pitcher\" attribute is a little bit funny. Usually, when
--   there's no pitcher, the attribute itself is missing. But once in
--   a blue moon, it will be present with no text. We want to treat
--   both cases the same, so what we really parse is a Maybe (Maybe
--   String), and then use the monad 'join' to collapse it into a single
--   Maybe.
--
pickle_vteam :: PU VTeamXml
pickle_vteam =
  xpElem "vteam" $
    xpWrap (from_tuple, to_tuple') $
      xpTriple (xpAttr "id" xpText)
               (xpOption $ xpAttr "pitcher" (xpOption xpText))
               (xpOption xpText) -- Team name
  where
    from_tuple (x,y,z) = VTeamXml (VTeam (Team x Nothing z)) (join y)

    to_tuple' (VTeamXml (VTeam t) Nothing) = (team_id t, Nothing, name t)
    to_tuple' (VTeamXml (VTeam t) jvp) = (team_id t, Just jvp, name t)


-- | Convert a 'HTeamXml' to/from \<hteam\>. Identical to 'pickle_vteam'
--   modulo the \"h\" and \"v\". The team names always seem to be
--   present here, but in the shared representation, they're optional
--   (because they show up blank elsewhere). So, we pretend they're
--   optional.
--
--   The \"pitcher\" attribute is a little bit funny. Usually, when
--   there's no pitcher, the attribute itself is missing. But once in
--   a blue moon, it will be present with no text. We want to treat
--   both cases the same, so what we really parse is a Maybe (Maybe
--   String), and then use the monad 'join' to collapse it into a single
--   Maybe.
--
pickle_hteam :: PU HTeamXml
pickle_hteam =
  xpElem "hteam" $
    xpWrap (from_tuple, to_tuple') $
      xpTriple (xpAttr "id" xpText)
               (xpOption $ xpAttr "pitcher" (xpOption xpText))
               (xpOption xpText) -- Team name
  where
    from_tuple (x,y,z)= HTeamXml (HTeam (Team x Nothing z)) (join y)
    to_tuple' (HTeamXml (HTeam t) jhp) = (team_id t, double_just jhp, name t)



--
-- * Tasty tests
--

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

    check "pickle composed with unpickle is the identity (no locations)"
          "test/xml/scoresxml-no-locations.xml",

    check "pickle composed with unpickle is the identity (pitcher, no type)"
          "test/xml/scoresxml-pitcher-no-type.xml",

    check "pickle composed with unpickle is the identity (empty numeral)"
          "test/xml/scoresxml-empty-numeral.xml",

    check "pickle composed with unpickle is the identity (empty type)"
          "test/xml/scoresxml-empty-type.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/scoresxml.xml",

    check "unpickling succeeds (no locations)"
          "test/xml/scoresxml-no-locations.xml",

    check "unpickling succeeds (pitcher, no type)"
          "test/xml/scoresxml-pitcher-no-type.xml",

    check "unpickling succeeds (empty numeral)"
          "test/xml/scoresxml-empty-numeral.xml",

    check "unpickling succeeds (empty type)"
          "test/xml/scoresxml-empty-type.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 "unpickling succeeds"
          "test/xml/scoresxml.xml"
          4, -- 2 teams, 2 locations

    check "unpickling succeeds (no locations)"
          "test/xml/scoresxml-no-locations.xml"
          2, -- 2 teams, 0 locations

    check "unpickling succeeds (pitcher, no type)"
          "test/xml/scoresxml-pitcher-no-type.xml"
          3, -- 2 teams, 1 location

    check "unpickling succeeds (empty numeral)"
          "test/xml/scoresxml-empty-numeral.xml"
          3, -- 2 teams, 1 location

    check "unpickling succeeds (empty type)"
          "test/xml/scoresxml-empty-type.xml"
          4 -- 2 teams, 2 locations
  ]
  where
    check desc path expected = testCase desc $ do
      score <- unsafe_unpickle path pickle_message
      let a = undefined :: Location
      let b = undefined :: Team
      let c = undefined :: Score
      let d = undefined :: ScoreGame
      let e = undefined :: Score_Location
      actual <- withSqliteConn ":memory:" $ runDbConn $ do
                  runMigrationSilent $ do
                    migrate a
                    migrate b
                    migrate c
                    migrate d
                    migrate e
                  _ <- dbimport score
                  -- No idea how 'delete' works, so do this instead.
                  deleteAll c
                  count_a <- countAll a
                  count_b <- countAll b
                  count_c <- countAll c
                  count_d <- countAll d
                  count_e <- countAll e
                  return $ sum [count_a, count_b, count_c,
                                count_d, count_e ]
      actual @?= expected