Use Generics.to_tuple in TSN.XML.MLBBoxScore.

This is similar to the last few commits, except some instances had to
be added and a compiler flag passed to GHC to get everything to
compile.

diff --git a/htsn-import.cabal b/htsn-import.cabal
index 2b488e21b6c244a42becaf148124f698823ef612..5597aa8790708bf1d02c9999473abb238dc0a752 100644 (file)
--- a/htsn-import.cabal
+++ b/htsn-import.cabal
@@ -308,6 +308,7 @@ executable htsn-import
 
   ghc-options:
     -Wall
 
   ghc-options:
     -Wall

+    -fcontext-stack=50

     -fwarn-hi-shadowing
     -fwarn-missing-signatures
     -fwarn-name-shadowing
     -fwarn-hi-shadowing
     -fwarn-missing-signatures
     -fwarn-name-shadowing


@@ -360,6 +361,7 @@ test-suite testsuite
   -- It's not entirely clear to me why I have to reproduce all of this.
   ghc-options:
     -Wall
   -- It's not entirely clear to me why I have to reproduce all of this.
   ghc-options:
     -Wall

+    -fcontext-stack=50

     -fwarn-hi-shadowing
     -fwarn-missing-signatures
     -fwarn-name-shadowing
     -fwarn-hi-shadowing
     -fwarn-missing-signatures
     -fwarn-name-shadowing


@@ -384,6 +386,7 @@ test-suite doctests
   -- It's not entirely clear to me why I have to reproduce all of this.
   ghc-options:
     -Wall
   -- It's not entirely clear to me why I have to reproduce all of this.
   ghc-options:
     -Wall

+    -fcontext-stack=50

     -fwarn-hi-shadowing
     -fwarn-missing-signatures
     -fwarn-name-shadowing
     -fwarn-hi-shadowing
     -fwarn-missing-signatures
     -fwarn-name-shadowing

diff --git a/src/Generics.hs b/src/Generics.hs
index 8e6658940fd0330cefe071e491c16bf13c6299d0..76a8a2b8230891f83f84d74601a70fa552cf85e9 100644 (file)
--- a/src/Generics.hs
+++ b/src/Generics.hs
@@ -2,12 +2,35 @@
 {-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE TypeFamilies #-}
 
 {-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE TypeFamilies #-}
 

+-- These can go if the tuple instances are accepted upstream.
+
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DataKinds #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+

 module Generics (
   Generic(..),
   to_tuple )
 where
 
 import Generics.SOP ( Code, Generic(..) )
 module Generics (
   Generic(..),
   to_tuple )
 where
 
 import Generics.SOP ( Code, Generic(..) )

+import Generics.SOP.TH ( deriveGeneric )
+
+deriveGeneric ''(,,,,,,,,,,,,,,,)
+deriveGeneric ''(,,,,,,,,,,,,,,,,)
+deriveGeneric ''(,,,,,,,,,,,,,,,,,)
+deriveGeneric ''(,,,,,,,,,,,,,,,,,,)
+deriveGeneric ''(,,,,,,,,,,,,,,,,,,,) -- 20
+deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,)
+deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,)
+deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,)
+deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,)
+deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,) -- 25
+deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,)
+deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,)
+deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,)
+deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,)
+deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) -- 30

 
 -- | Convert a simple product type into a tuple, generically.
 --
 
 -- | Convert a simple product type into a tuple, generically.
 --

diff --git a/src/TSN/XML/MLBBoxScore.hs b/src/TSN/XML/MLBBoxScore.hs
index ee6ad443e6ba188de142af92bfc7cea307923510..39109b2ded73f1fe9ea2f390ba377764ef42fbfc 100644 (file)
--- a/src/TSN/XML/MLBBoxScore.hs
+++ b/src/TSN/XML/MLBBoxScore.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric #-}

 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE QuasiQuotes #-}


@@ -11,51 +12,47 @@ module TSN.XML.MLBBoxScore (
   dtd,
   pickle_message,
   -- * Tests
   dtd,
   pickle_message,
   -- * Tests

---  auto_racing_results_tests,
+  --  auto_racing_results_tests,

   -- * WARNING: these are private but exported to silence warnings
   -- * WARNING: these are private but exported to silence warnings

-  MLBBoxScoreConstructor(..) )
+  MLBBoxScoreConstructor(..),
+  MLBBoxScoreGameBreakdown(..),
+  MLBBoxScoreHomerunStats(..),
+  MLBBoxScoreMiscellaneousGameInfo(..),
+  MLBBoxScoreMiscPitchingStats(..),
+  MLBBoxScoreTeamSummary(..)
+ )

 --  AutoRacingResultsListingConstructor(..),
 --  AutoRacingResultsRaceInformationConstructor(..) )
 where
 
 -- System imports.
 --  AutoRacingResultsListingConstructor(..),
 --  AutoRacingResultsRaceInformationConstructor(..) )
 where
 
 -- System imports.

-import Control.Monad ( forM_ )

 import Data.Time ( UTCTime(..) )
 import Data.Tuple.Curry ( uncurryN )
 import Database.Groundhog (
 import Data.Time ( UTCTime(..) )
 import Data.Tuple.Curry ( uncurryN )
 import Database.Groundhog (

-  countAll,
-  deleteAll,

   insert,
   insert,

-  migrate,
-  runMigration,
-  silentMigrationLogger )
+  migrate )

 import Database.Groundhog.Core ( DefaultKey )
 import Database.Groundhog.Core ( DefaultKey )

-import Database.Groundhog.Generic ( runDbConn )
-import Database.Groundhog.Sqlite ( withSqliteConn )

 import Database.Groundhog.TH (
   groundhog,
   mkPersist )
 import Database.Groundhog.TH (
   groundhog,
   mkPersist )

-import Test.Tasty ( TestTree, testGroup )
-import Test.Tasty.HUnit ( (@?=), testCase )
+import qualified GHC.Generics as GHC ( Generic )

 import Text.XML.HXT.Core (
   PU,
   xp4Tuple,
 import Text.XML.HXT.Core (
   PU,
   xp4Tuple,

-  xp11Tuple,

   xp23Tuple,
   xpAttr,
   xp23Tuple,
   xpAttr,

-  xpDefault,

   xpElem,
   xpInt,
   xpList,
   xpOption,
   xpPair,
   xpElem,
   xpInt,
   xpList,
   xpOption,
   xpPair,

-  xpPrim,

   xpText,
   xpTriple,
   xpUnit,
   xpWrap )
 
 -- Local imports.
   xpText,
   xpTriple,
   xpUnit,
   xpWrap )
 
 -- Local imports.

+import Generics ( Generic(..), to_tuple )

 import TSN.Codegen ( tsn_codegen_config )
 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
 import TSN.Picklers (
 import TSN.Codegen ( tsn_codegen_config )
 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
 import TSN.Picklers (


@@ -63,15 +60,9 @@ import TSN.Picklers (
   xp_time,
   xp_time_stamp )
 import TSN.Team ( Team(..), FromXmlFkTeams(..) )
   xp_time,
   xp_time_stamp )
 import TSN.Team ( Team(..), FromXmlFkTeams(..) )

-import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )

 import Xml (
   Child(..),
 import Xml (
   Child(..),

-  FromXml(..),
-  FromXmlFk(..),
-  ToDb(..),
-  pickle_unpickle,
-  unpickleable,
-  unsafe_unpickle )
+  ToDb(..) )

 
 
 -- | The DTD to which this module corresponds. Used to invoke dbimport.
 
 
 -- | The DTD to which this module corresponds. Used to invoke dbimport.


@@ -142,7 +133,12 @@ data Message =
     xml_homerun_stats :: Maybe MLBBoxScoreHomerunStatsXml,
     xml_miscellaneous_game_info :: MLBBoxScoreMiscellaneousGameInfoXml,
     xml_time_stamp :: UTCTime }
     xml_homerun_stats :: Maybe MLBBoxScoreHomerunStatsXml,
     xml_miscellaneous_game_info :: MLBBoxScoreMiscellaneousGameInfoXml,
     xml_time_stamp :: UTCTime }

-  deriving (Eq, Show)
+  deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'Generics.to_tuple'.
+--
+instance Generic Message

 
 
 instance ToDb Message where
 
 
 instance ToDb Message where


@@ -203,7 +199,12 @@ data MLBBoxScoreGameBreakdownXml =
   MLBBoxScoreGameBreakdownXml {
     xml_away_team :: MLBBoxScoreGameBreakdownTeamXml,
     xml_home_team :: MLBBoxScoreGameBreakdownTeamXml }
   MLBBoxScoreGameBreakdownXml {
     xml_away_team :: MLBBoxScoreGameBreakdownTeamXml,
     xml_home_team :: MLBBoxScoreGameBreakdownTeamXml }

-  deriving (Eq, Show)
+  deriving (Eq, GHC.Generic, Show)
+
+-- | For 'Generics.to_tuple'
+--
+instance Generic MLBBoxScoreGameBreakdownXml
+

 
 data MLBBoxScoreHomerunStats = MLBBoxScoreHomerunStats
 data MLBBoxScoreHomerunStatsXml = MLBBoxScoreHomerunStatsXml
 
 data MLBBoxScoreHomerunStats = MLBBoxScoreHomerunStats
 data MLBBoxScoreHomerunStatsXml = MLBBoxScoreHomerunStatsXml


@@ -219,13 +220,23 @@ data MLBBoxScoreGameBreakdownTeamXml =
     xml_runs :: Int,
     xml_hits :: Int,
     xml_errors :: Int }
     xml_runs :: Int,
     xml_hits :: Int,
     xml_errors :: Int }

-  deriving (Eq, Show)
+  deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'Generics.to_tuple'.
+instance Generic MLBBoxScoreGameBreakdownTeamXml
+

 
 data MLBBoxScoreRunsByInningsXml =
   MLBBoxScoreRunsByInningsXml {
     xml_runs_by_innings_inning_number :: Int,
     xml_runs_by_innings_runs   :: Int }
 
 data MLBBoxScoreRunsByInningsXml =
   MLBBoxScoreRunsByInningsXml {
     xml_runs_by_innings_inning_number :: Int,
     xml_runs_by_innings_runs   :: Int }

-  deriving (Eq, Show)
+  deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'Generics.to_tuple'.
+--
+instance Generic MLBBoxScoreRunsByInningsXml

 
 
 data MLBBoxScoreMiscPitchingStats = MLBBoxScoreMiscPitchingStats
 
 
 data MLBBoxScoreMiscPitchingStats = MLBBoxScoreMiscPitchingStats


@@ -234,21 +245,37 @@ data MLBBoxScoreMiscPitchingStatsXml =
     xml_wild_pitches :: Maybe Int,
     xml_intentional_walks :: [MLBBoxScoreMiscPitchingStatsIntentionalWalkXml],
     xml_hits_by_pitch :: [MLBBoxScoreMiscPitchingStatsHitByPitchXml] }
     xml_wild_pitches :: Maybe Int,
     xml_intentional_walks :: [MLBBoxScoreMiscPitchingStatsIntentionalWalkXml],
     xml_hits_by_pitch :: [MLBBoxScoreMiscPitchingStatsHitByPitchXml] }

-  deriving (Eq, Show)
+  deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'Generics.to_tuple'.
+instance Generic MLBBoxScoreMiscPitchingStatsXml
+

 
 data MLBBoxScoreMiscPitchingStatsIntentionalWalkXml =
   MLBBoxScoreMiscPitchingStatsIntentionalWalkXml {
     xml_iw_batter_id :: Int,
     xml_iw_pitcher_id :: Int,
     xml_iw_number_of_times_walked :: Int }
 
 data MLBBoxScoreMiscPitchingStatsIntentionalWalkXml =
   MLBBoxScoreMiscPitchingStatsIntentionalWalkXml {
     xml_iw_batter_id :: Int,
     xml_iw_pitcher_id :: Int,
     xml_iw_number_of_times_walked :: Int }

-  deriving (Eq, Show)
+  deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'Generics.to_tuple'.
+instance Generic MLBBoxScoreMiscPitchingStatsIntentionalWalkXml
+

 
 data MLBBoxScoreMiscPitchingStatsHitByPitchXml =
   MLBBoxScoreMiscPitchingStatsHitByPitchXml {
     xml_hbp_batter_id :: Int,
     xml_hbp_pitcher_id :: Int,
     xml_hbp_number_of_times_hit :: Int }
 
 data MLBBoxScoreMiscPitchingStatsHitByPitchXml =
   MLBBoxScoreMiscPitchingStatsHitByPitchXml {
     xml_hbp_batter_id :: Int,
     xml_hbp_pitcher_id :: Int,
     xml_hbp_number_of_times_hit :: Int }

-  deriving (Eq, Show)
+  deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'Generics.to_tuple'.
+--
+instance Generic MLBBoxScoreMiscPitchingStatsHitByPitchXml
+

 
 --
 -- * Database
 
 --
 -- * Database


@@ -272,7 +299,7 @@ instance DbImport Message where
     -- Now we can key the message to the teams we just inserted.
     -- The message has no parent, so we pass in undefined.
     let db_msg = from_xml_fk_teams undefined vteam_fk hteam_fk m
     -- Now we can key the message to the teams we just inserted.
     -- The message has no parent, so we pass in undefined.
     let db_msg = from_xml_fk_teams undefined vteam_fk hteam_fk m

-    msg_id <- insert db_msg
+    _ <- insert db_msg

 
     -- Now get the hteam
     return ImportSucceeded
 
     -- Now get the hteam
     return ImportSucceeded


@@ -327,37 +354,14 @@ pickle_message =
                 (xpElem "time_stamp" xp_time_stamp)
   where
     from_tuple = uncurryN Message
                 (xpElem "time_stamp" xp_time_stamp)
   where
     from_tuple = uncurryN Message

-    to_tuple m = (xml_xml_file_id m,
-                  xml_heading m,
-                  xml_category m,
-                  xml_sport m,
-                  xml_game_id m,
-                  xml_schedule_id m,
-                  xml_vteam m,
-                  xml_hteam m,
-                  xml_vteam_id m,
-                  xml_hteam_id m,
-                  xml_season m,
-                  xml_season_type m,
-                  xml_title m,
-                  xml_game_date m,
-                  xml_game_time m,
-                  xml_game_number m,
-                  xml_capacity m,
-                  xml_game_breakdown m,
-                  xml_team_summaries m,
-                  xml_misc_pitching_stats m,
-                  xml_homerun_stats m,
-                  xml_miscellaneous_game_info m,
-                  xml_time_stamp m)

 
 
 pickle_team_summary :: PU MLBBoxScoreTeamSummaryXml
 pickle_team_summary =
 
 
 pickle_team_summary :: PU MLBBoxScoreTeamSummaryXml
 pickle_team_summary =

-  xpElem "Team_Summary" $ xpWrap (from_tuple, to_tuple) $ xpUnit
+  xpElem "Team_Summary" $ xpWrap (from_tuple, to_tuple') $ xpUnit

   where
     from_tuple _ = MLBBoxScoreTeamSummaryXml
   where
     from_tuple _ = MLBBoxScoreTeamSummaryXml

-    to_tuple   _ = ()
+    to_tuple'   _ = ()

 
 pickle_game_breakdown :: PU MLBBoxScoreGameBreakdownXml
 pickle_game_breakdown =
 
 pickle_game_breakdown :: PU MLBBoxScoreGameBreakdownXml
 pickle_game_breakdown =


@@ -367,7 +371,6 @@ pickle_game_breakdown =
              pickle_home_team
   where
     from_tuple = uncurry MLBBoxScoreGameBreakdownXml
              pickle_home_team
   where
     from_tuple = uncurry MLBBoxScoreGameBreakdownXml

-    to_tuple MLBBoxScoreGameBreakdownXml{..} = (xml_away_team, xml_home_team)

 
 
 pickle_runs_by_innings :: PU MLBBoxScoreRunsByInningsXml
 
 
 pickle_runs_by_innings :: PU MLBBoxScoreRunsByInningsXml


@@ -378,9 +381,9 @@ pickle_runs_by_innings =
              xpInt
   where
     from_tuple = uncurry MLBBoxScoreRunsByInningsXml
              xpInt
   where
     from_tuple = uncurry MLBBoxScoreRunsByInningsXml

-    to_tuple MLBBoxScoreRunsByInningsXml{..} =
-      (xml_runs_by_innings_inning_number, xml_runs_by_innings_runs)

 
 

+
+pickle_team :: PU MLBBoxScoreGameBreakdownTeamXml

 pickle_team =
   xpWrap (from_tuple, to_tuple) $
     xp4Tuple (xpList pickle_runs_by_innings)
 pickle_team =
   xpWrap (from_tuple, to_tuple) $
     xp4Tuple (xpList pickle_runs_by_innings)


@@ -389,8 +392,7 @@ pickle_team =
              (xpElem "Errors" xpInt)
   where
     from_tuple = uncurryN MLBBoxScoreGameBreakdownTeamXml
              (xpElem "Errors" xpInt)
   where
     from_tuple = uncurryN MLBBoxScoreGameBreakdownTeamXml

-    to_tuple MLBBoxScoreGameBreakdownTeamXml{..} =
-      (xml_runs_by_innings, xml_runs, xml_hits, xml_errors)
+

 
 pickle_away_team :: PU MLBBoxScoreGameBreakdownTeamXml
 pickle_away_team =
 
 pickle_away_team :: PU MLBBoxScoreGameBreakdownTeamXml
 pickle_away_team =


@@ -402,10 +404,10 @@ pickle_home_team =
 
 pickle_homerun_stats :: PU (Maybe MLBBoxScoreHomerunStatsXml)
 pickle_homerun_stats =
 
 pickle_homerun_stats :: PU (Maybe MLBBoxScoreHomerunStatsXml)
 pickle_homerun_stats =

-  xpOption $ xpElem "Homerun_Stats" $ xpWrap (from_tuple, to_tuple) $ xpUnit
+  xpOption $ xpElem "Homerun_Stats" $ xpWrap (from_tuple, to_tuple') $ xpUnit

   where
     from_tuple _ = MLBBoxScoreHomerunStatsXml
   where
     from_tuple _ = MLBBoxScoreHomerunStatsXml

-    to_tuple   _ = ()
+    to_tuple'   _ = ()

 
 
 pickle_misc_pitching_stats :: PU MLBBoxScoreMiscPitchingStatsXml
 
 
 pickle_misc_pitching_stats :: PU MLBBoxScoreMiscPitchingStatsXml


@@ -417,8 +419,7 @@ pickle_misc_pitching_stats =
                pickle_hits_by_pitch
   where
     from_tuple = uncurryN MLBBoxScoreMiscPitchingStatsXml
                pickle_hits_by_pitch
   where
     from_tuple = uncurryN MLBBoxScoreMiscPitchingStatsXml

-    to_tuple MLBBoxScoreMiscPitchingStatsXml{..} =
-      (xml_wild_pitches, xml_intentional_walks, xml_hits_by_pitch)
+

 
 
 pickle_intentional_walks :: PU [MLBBoxScoreMiscPitchingStatsIntentionalWalkXml]
 
 
 pickle_intentional_walks :: PU [MLBBoxScoreMiscPitchingStatsIntentionalWalkXml]


@@ -430,8 +431,7 @@ pickle_intentional_walks =
                (xpElem "IW_Number_Of_Times_Walked" xpInt)
   where
     from_tuple = uncurryN MLBBoxScoreMiscPitchingStatsIntentionalWalkXml
                (xpElem "IW_Number_Of_Times_Walked" xpInt)
   where
     from_tuple = uncurryN MLBBoxScoreMiscPitchingStatsIntentionalWalkXml

-    to_tuple MLBBoxScoreMiscPitchingStatsIntentionalWalkXml{..} =
-      (xml_iw_batter_id, xml_iw_pitcher_id, xml_iw_number_of_times_walked)
+

 
 
 pickle_hits_by_pitch :: PU [MLBBoxScoreMiscPitchingStatsHitByPitchXml]
 
 
 pickle_hits_by_pitch :: PU [MLBBoxScoreMiscPitchingStatsHitByPitchXml]


@@ -443,14 +443,12 @@ pickle_hits_by_pitch =
                (xpElem "HBP_Number_Of_Times_Hit" xpInt)
   where
     from_tuple = uncurryN MLBBoxScoreMiscPitchingStatsHitByPitchXml
                (xpElem "HBP_Number_Of_Times_Hit" xpInt)
   where
     from_tuple = uncurryN MLBBoxScoreMiscPitchingStatsHitByPitchXml

-    to_tuple MLBBoxScoreMiscPitchingStatsHitByPitchXml{..} =
-      (xml_hbp_batter_id, xml_hbp_pitcher_id, xml_hbp_number_of_times_hit)

 
 
 
 pickle_miscellaneous_game_info :: PU MLBBoxScoreMiscellaneousGameInfoXml
 pickle_miscellaneous_game_info =
 
 
 
 pickle_miscellaneous_game_info :: PU MLBBoxScoreMiscellaneousGameInfoXml
 pickle_miscellaneous_game_info =

-  xpElem "Miscelaneous_Game_Info" $ xpWrap (from_tuple, to_tuple) $ xpUnit
+  xpElem "Miscelaneous_Game_Info" $ xpWrap (from_tuple, to_tuple') $ xpUnit

   where
     from_tuple _ = MLBBoxScoreMiscellaneousGameInfoXml
   where
     from_tuple _ = MLBBoxScoreMiscellaneousGameInfoXml

-    to_tuple   _ = ()
+    to_tuple'  _ = ()