From: Michael Orlitzky Date: Tue, 30 Dec 2014 20:40:30 +0000 (-0500) Subject: Use Generics.to_tuple in TSN.XML.MLBBoxScore. X-Git-Tag: 0.2.1~43 X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Fhtsn-import.git;a=commitdiff_plain;h=c0dd6db82ddf70ab3cc940f23c0cfcc6d8bb9355 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 2b488e2..5597aa8 100644 --- a/htsn-import.cabal +++ b/htsn-import.cabal @@ -308,6 +308,7 @@ executable htsn-import ghc-options: -Wall + -fcontext-stack=50 -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 + -fcontext-stack=50 -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 + -fcontext-stack=50 -fwarn-hi-shadowing -fwarn-missing-signatures -fwarn-name-shadowing diff --git a/src/Generics.hs b/src/Generics.hs index 8e66589..76a8a2b 100644 --- a/src/Generics.hs +++ b/src/Generics.hs @@ -2,12 +2,35 @@ {-# 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(..) ) +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. -- diff --git a/src/TSN/XML/MLBBoxScore.hs b/src/TSN/XML/MLBBoxScore.hs index ee6ad44..39109b2 100644 --- a/src/TSN/XML/MLBBoxScore.hs +++ b/src/TSN/XML/MLBBoxScore.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} @@ -11,51 +12,47 @@ module TSN.XML.MLBBoxScore ( dtd, pickle_message, -- * Tests --- auto_racing_results_tests, + -- auto_racing_results_tests, -- * WARNING: these are private but exported to silence warnings - MLBBoxScoreConstructor(..) ) + MLBBoxScoreConstructor(..), + MLBBoxScoreGameBreakdown(..), + MLBBoxScoreHomerunStats(..), + MLBBoxScoreMiscellaneousGameInfo(..), + MLBBoxScoreMiscPitchingStats(..), + MLBBoxScoreTeamSummary(..) + ) -- AutoRacingResultsListingConstructor(..), -- AutoRacingResultsRaceInformationConstructor(..) ) where -- System imports. -import Control.Monad ( forM_ ) import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) import Database.Groundhog ( - countAll, - deleteAll, insert, - migrate, - runMigration, - silentMigrationLogger ) + migrate ) import Database.Groundhog.Core ( DefaultKey ) -import Database.Groundhog.Generic ( runDbConn ) -import Database.Groundhog.Sqlite ( withSqliteConn ) 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, - xp11Tuple, xp23Tuple, xpAttr, - xpDefault, xpElem, xpInt, xpList, xpOption, xpPair, - xpPrim, 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 ( @@ -63,15 +60,9 @@ import TSN.Picklers ( xp_time, xp_time_stamp ) import TSN.Team ( Team(..), FromXmlFkTeams(..) ) -import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) import Xml ( Child(..), - FromXml(..), - FromXmlFk(..), - ToDb(..), - pickle_unpickle, - unpickleable, - unsafe_unpickle ) + ToDb(..) ) -- | 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 } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'Generics.to_tuple'. +-- +instance Generic Message instance ToDb Message where @@ -203,7 +199,12 @@ data MLBBoxScoreGameBreakdownXml = 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 @@ -219,13 +220,23 @@ data MLBBoxScoreGameBreakdownTeamXml = 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 } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'Generics.to_tuple'. +-- +instance Generic MLBBoxScoreRunsByInningsXml data MLBBoxScoreMiscPitchingStats = MLBBoxScoreMiscPitchingStats @@ -234,21 +245,37 @@ data MLBBoxScoreMiscPitchingStatsXml = 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 } - 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 } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'Generics.to_tuple'. +-- +instance Generic MLBBoxScoreMiscPitchingStatsHitByPitchXml + -- -- * 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 - msg_id <- insert db_msg + _ <- insert db_msg -- Now get the hteam return ImportSucceeded @@ -327,37 +354,14 @@ pickle_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 = - xpElem "Team_Summary" $ xpWrap (from_tuple, to_tuple) $ xpUnit + xpElem "Team_Summary" $ xpWrap (from_tuple, to_tuple') $ xpUnit where from_tuple _ = MLBBoxScoreTeamSummaryXml - to_tuple _ = () + to_tuple' _ = () pickle_game_breakdown :: PU MLBBoxScoreGameBreakdownXml pickle_game_breakdown = @@ -367,7 +371,6 @@ pickle_game_breakdown = pickle_home_team where from_tuple = uncurry MLBBoxScoreGameBreakdownXml - to_tuple MLBBoxScoreGameBreakdownXml{..} = (xml_away_team, xml_home_team) pickle_runs_by_innings :: PU MLBBoxScoreRunsByInningsXml @@ -378,9 +381,9 @@ pickle_runs_by_innings = 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) @@ -389,8 +392,7 @@ pickle_team = (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 = @@ -402,10 +404,10 @@ pickle_home_team = 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 - to_tuple _ = () + to_tuple' _ = () pickle_misc_pitching_stats :: PU MLBBoxScoreMiscPitchingStatsXml @@ -417,8 +419,7 @@ pickle_misc_pitching_stats = 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] @@ -430,8 +431,7 @@ pickle_intentional_walks = (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] @@ -443,14 +443,12 @@ pickle_hits_by_pitch = (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 = - xpElem "Miscelaneous_Game_Info" $ xpWrap (from_tuple, to_tuple) $ xpUnit + xpElem "Miscelaneous_Game_Info" $ xpWrap (from_tuple, to_tuple') $ xpUnit where from_tuple _ = MLBBoxScoreMiscellaneousGameInfoXml - to_tuple _ = () + to_tuple' _ = ()