--- /dev/null
+{-# 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 (
+ pickle_message,
+ -- * Tests
+ scores_tests,
+ -- * WARNING: these are private but exported to silence warnings
+ Score_ScoreLocationConstructor(..),
+ ScoreConstructor(..),
+ ScoreGameConstructor(..),
+ ScoreGameTeamConstructor(..),
+ ScoreLocationConstructor(..),
+ ScoreGame_ScoreGameTeamConstructor(..) )
+where
+
+-- System imports.
+import Control.Monad ( forM_ )
+import Data.Data ( Data )
+import Data.Time ( UTCTime )
+import Data.Tuple.Curry ( uncurryN )
+import Data.Typeable ( Typeable )
+import Database.Groundhog (
+ countAll,
+ executeRaw,
+ migrate,
+ runMigration,
+ silentMigrationLogger )
+import Database.Groundhog.Core ( DefaultKey )
+import Database.Groundhog.Generic ( runDbConn )
+import Database.Groundhog.Sqlite ( withSqliteConn )
+import Database.Groundhog.TH (
+ defaultCodegenConfig,
+ groundhog,
+ mkPersist )
+import Test.Tasty ( TestTree, testGroup )
+import Test.Tasty.HUnit ( (@?=), testCase )
+import Text.XML.HXT.Core (
+ PU,
+ xp7Tuple,
+ xp11Tuple,
+ xp12Tuple,
+ xpAttr,
+ 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_gamedate, xp_time_stamp )
+import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
+import Xml (
+ FromXml(..),
+ FromXmlFk(..),
+ ToDb(..),
+ pickle_unpickle,
+ unpickleable,
+ unsafe_unpickle )
+
+
+--
+-- DB/XML Data types
+--
+
+
+-- * Score / Message
+
+data Score =
+ Score {
+ db_xml_file_id :: Int,
+ db_heading :: String,
+ db_game_id :: Int,
+ db_schedule_id :: Int,
+ db_tsnupdate :: Maybe Bool,
+ db_category :: String,
+ db_sport :: String,
+ db_season_type :: String,
+ db_time_stamp :: UTCTime }
+
+data Message =
+ Message {
+ xml_xml_file_id :: Int,
+ xml_heading :: String,
+ xml_game_id :: Int,
+ xml_schedule_id :: Int,
+ xml_tsnupdate :: Maybe Bool,
+ xml_category :: String,
+ xml_sport :: String,
+ xml_locations :: [ScoreLocation],
+ xml_season_type :: String,
+ xml_game :: ScoreGameXml,
+ xml_time_stamp :: UTCTime }
+ deriving (Eq, Show)
+
+
+-- * ScoreGame / ScoreGameXml
+
+data ScoreGameStatus =
+ ScoreGameStatus {
+ db_status_numeral :: Int,
+ db_status_type :: 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)
+
+data ScoreGame =
+ ScoreGame {
+ db_scores_id :: DefaultKey Score,
+ db_vscore :: Int,
+ db_hscore :: Int,
+ db_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
+ db_status :: ScoreGameStatus,
+ db_notes :: Maybe String }
+
+
+data ScoreGameXml =
+ ScoreGameXml {
+ xml_vteam :: ScoreGameVTeam,
+ xml_hteam :: ScoreGameHTeam,
+ xml_vscore :: Int,
+ xml_hscore :: Int,
+ xml_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
+ xml_status :: ScoreGameStatus,
+ xml_notes :: Maybe String }
+ deriving (Eq, Show)
+
+-- * ScoreGameTeam
+
+data ScoreGameTeam =
+ ScoreGameTeam {
+ team_id :: String,
+ team_name :: String }
+ deriving (Eq, Show)
+
+newtype ScoreGameVTeam =
+ ScoreGameVTeam ScoreGameTeam
+ deriving (Eq, Show)
+
+newtype ScoreGameHTeam =
+ ScoreGameHTeam ScoreGameTeam
+ deriving (Eq, Show)
+
+-- * ScoreGame_ScoreGameTeam
+
+-- | Join a ScoreGame with its home/away teams.
+--
+data ScoreGame_ScoreGameTeam =
+ ScoreGame_ScoreGameTeam
+ (DefaultKey ScoreGame) -- ^ game id
+ (DefaultKey ScoreGameTeam) -- ^ vteam id
+ (DefaultKey ScoreGameTeam) -- ^ hteam id
+
+
+-- * ScoreLocation
+
+data ScoreLocation =
+ ScoreLocation {
+ city :: Maybe String,
+ state :: Maybe String,
+ country :: String }
+ deriving (Eq, Show)
+
+
+-- * Score_ScoreLocation
+
+data Score_ScoreLocation =
+ Score_ScoreLocation
+ (DefaultKey Score)
+ (DefaultKey ScoreLocation)
+
+
+
+
+
+-- These types don't have special XML representations or field name
+-- collisions so we use the defaultCodegenConfig and give their
+-- fields nice simple names.
+mkPersist defaultCodegenConfig [groundhog|
+- entity: ScoreGameTeam
+ dbName: scores_games_teams
+ constructors:
+ - name: ScoreGameTeam
+ uniques:
+ - name: unique_scores_games_team
+ type: constraint
+ fields: [team_id]
+
+- entity: ScoreLocation
+ dbName: scores_locations
+ constructors:
+ - name: ScoreLocation
+ uniques:
+ - name: unique_scores_location
+ type: constraint
+ fields: [city, state, country]
+
+|]
+
+
+
+-- 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
+ 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: ScoreGame_ScoreGameTeam
+ dbName: scores__scores_games_teams
+ constructors:
+ - name: ScoreGame_ScoreGameTeam
+ fields:
+ - name: scoreGame_ScoreGameTeam0 # Default created by mkNormalFieldName
+ dbName: scores_games_id
+ reference:
+ onDelete: cascade
+ - name: scoreGame_ScoreGameTeam1 # Default created by mkNormalFieldName
+ dbName: scores_games_teams_vteam_id
+ reference:
+ onDelete: cascade
+ - name: scoreGame_ScoreGameTeam2 # Default created by mkNormalFieldName
+ dbName: scores_games_teams_hteam_id
+ reference:
+ onDelete: cascade
+
+- entity: Score_ScoreLocation
+ dbName: scores__scores_locations
+ constructors:
+ - name: Score_ScoreLocation
+ fields:
+ - name: score_ScoreLocation0 # Default created by mkNormalFieldName
+ dbName: scores_id
+ reference:
+ onDelete: cascade
+ - name: score_ScoreLocation1 # Default created by mkNormalFieldName
+ dbName: scores_locations_id
+ reference:
+ onDelete: cascade
+|]
+
+
+--
+-- Pickling
+--
+
+-- | Convert a 'Message' to/from XML.
+--
+pickle_message :: PU Message
+pickle_message =
+ xpElem "message" $
+ xpWrap (from_tuple, to_tuple) $
+ xp11Tuple (xpElem "XML_File_ID" xpInt)
+ (xpElem "heading" xpText)
+ (xpElem "game_id" xpInt)
+ (xpElem "schedule_id" xpInt)
+ (xpOption $ xpElem "tsnupdate" xpPrim)
+ (xpElem "category" xpText)
+ (xpElem "sport" xpText)
+ (xpList pickle_location)
+ (xpElem "seasontype" xpText)
+ pickle_game
+ (xpElem "time_stamp" xp_time_stamp)
+ where
+ from_tuple = uncurryN Message
+ to_tuple m = (xml_xml_file_id m,
+ xml_heading m,
+ xml_game_id m,
+ xml_schedule_id m,
+ xml_tsnupdate m,
+ xml_category m,
+ xml_sport m,
+ xml_locations m,
+ xml_season_type m,
+ xml_game m,
+ xml_time_stamp m)
+
+
+
+-- | Convert a 'ScoreLocation' to/from XML.
+--
+pickle_location :: PU ScoreLocation
+pickle_location =
+ xpElem "location" $
+ xpWrap (from_tuple, to_tuple) $
+ xpTriple (xpOption (xpElem "city" xpText))
+ (xpOption (xpElem "state" xpText))
+ (xpElem "country" xpText)
+ where
+ from_tuple =
+ uncurryN ScoreLocation
+ to_tuple l = (city l, state l, country l)
+
+
+pickle_status :: PU ScoreGameStatus
+pickle_status =
+ xpElem "status" $
+ xpWrap (from_tuple, to_tuple) $
+ xpTriple (xpAttr "numeral" xpInt)
+ (xpAttr "type" xpText)
+ xpText
+ where
+ from_tuple = uncurryN ScoreGameStatus
+ to_tuple (ScoreGameStatus x y z) = (x,y,z)
+
+pickle_game :: PU ScoreGameXml
+pickle_game =
+ xpElem "game" $
+ xpWrap (from_tuple, to_tuple) $
+ 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
+ to_tuple ScoreGameXml{..} = (xml_vteam,
+ xml_hteam,
+ xml_vscore,
+ xml_hscore,
+ xml_time_r,
+ xml_status,
+ xml_notes)
+
+
+pickle_vteam :: PU ScoreGameVTeam
+pickle_vteam =
+ xpElem "vteam" $
+ xpWrap (from_tuple, to_tuple) $
+ xpPair (xpAttr "id" xpText)
+ xpText
+ where
+ from_tuple = ScoreGameVTeam . uncurry ScoreGameTeam
+ to_tuple (ScoreGameVTeam (ScoreGameTeam x y)) = (x,y)
+
+
+pickle_hteam :: PU ScoreGameHTeam
+pickle_hteam =
+ xpElem "hteam" $
+ xpWrap (from_tuple, to_tuple) $
+ xpPair (xpAttr "id" xpText)
+ xpText
+ where
+ from_tuple = ScoreGameHTeam . uncurry ScoreGameTeam
+ to_tuple (ScoreGameHTeam (ScoreGameTeam x y)) = (x,y)
+
+
+---
+--- Tasty tests
+---
+
+-- | A list of all tests for this module.
+--
+scores_tests :: TestTree
+scores_tests =
+ testGroup
+ "Scores tests"
+ [ 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" ]
+ 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" ]
+ where
+ check desc path = testCase desc $ do
+ actual <- unpickleable path pickle_message
+ let expected = True
+ actual @?= expected
projects / dead / htsn-import.git / commitdiff