From 2dd451a3963893ab2d5d6c0dd2902502bb93a05a Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Fri, 2 Jan 2015 16:22:21 -0500 Subject: [PATCH] Migrate TSN.XML.InjuriesDetail to fixed-vector-hetero. --- src/TSN/XML/InjuriesDetail.hs | 92 ++++++++++++++++++----------------- 1 file changed, 47 insertions(+), 45 deletions(-) diff --git a/src/TSN/XML/InjuriesDetail.hs b/src/TSN/XML/InjuriesDetail.hs index 90fb0cd..4dda844 100644 --- a/src/TSN/XML/InjuriesDetail.hs +++ b/src/TSN/XML/InjuriesDetail.hs @@ -27,6 +27,8 @@ where import Control.Monad ( forM_ ) import Data.Time ( UTCTime ) import Data.Tuple.Curry ( uncurryN ) +import qualified Data.Vector.HFixed as H ( HVector, cons, convert, tail ) +import qualified Data.Vector.HFixed.Cont as H (ContVec) import Database.Groundhog ( DefaultKey, countAll, @@ -56,7 +58,6 @@ import Text.XML.HXT.Core ( xpWrap ) -- Local imports. -import Generics ( Generic(..), to_tuple ) import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Picklers( xp_date, xp_time_stamp ) @@ -100,9 +101,9 @@ data Message = deriving (Eq, GHC.Generic, Show) --- | For 'Generics.to_tuple'. +-- | For 'H.convert'. -- -instance Generic Message +instance H.HVector Message -- | Database representation of a 'Message'. @@ -166,9 +167,9 @@ data InjuriesDetailListingXml = deriving (Eq, GHC.Generic, Show) --- | For 'Generics.to_tuple'. +-- | For 'H.convert'. -- -instance Generic InjuriesDetailListingXml +instance H.HVector InjuriesDetailListingXml instance ToDb InjuriesDetailListingXml where @@ -203,11 +204,12 @@ instance XmlImportFk InjuriesDetailListingXml -- * InjuriesDetailListingPlayerListing -- | XML representation of a \, the main type of --- element contains in Injuries_Detail_XML messages. +-- element contains in Injuries_Detail_XML messages. The leading +-- underscores prevent unused field warnings. -- data InjuriesDetailListingPlayerListingXml = InjuriesDetailListingPlayerListingXml { - xml_player_team_id :: String, -- ^ TeamIDs are (apparently) three + _xml_player_team_id :: String, -- ^ TeamIDs are (apparently) three -- characters long and not -- necessarily numeric. Postgres -- imposes no performance penalty @@ -216,39 +218,45 @@ data InjuriesDetailListingPlayerListingXml = -- bound of three characters. -- We add the \"player\" to avoid conflict -- with 'InjuriesDetailListingXml'. - xml_player_id :: Int, - xml_date :: UTCTime, - xml_pos :: String, - xml_name :: String, - xml_injury :: String, - xml_status :: String, - xml_fantasy :: Maybe String, -- ^ Nobody knows what this is. - xml_injured :: Bool, - xml_type :: String } + _xml_player_id :: Int, + _xml_date :: UTCTime, + _xml_pos :: String, + _xml_name :: String, + _xml_injury :: String, + _xml_status :: String, + _xml_fantasy :: Maybe String, -- ^ Nobody knows what this is. + _xml_injured :: Bool, + _xml_type :: String } deriving (Eq, GHC.Generic, Show) --- | For 'Generics.to_tuple'. +-- | For 'H.convert'. -- -instance Generic InjuriesDetailListingPlayerListingXml +instance H.HVector InjuriesDetailListingPlayerListingXml -- | Database representation of a -- 'InjuriesDetailListingPlayerListingXml'. We drop the team_id --- because it's redundant. +-- because it's redundant. The leading underscores prevent unused +-- field warnings. -- data InjuriesDetailListingPlayerListing = InjuriesDetailListingPlayerListing { - db_injuries_detail_listings_id :: DefaultKey InjuriesDetailListing, - db_player_id :: Int, - db_date :: UTCTime, - db_pos :: String, - db_name :: String, - db_injury :: String, - db_status :: String, - db_fantasy :: Maybe String, -- ^ Nobody knows what this is. - db_injured :: Bool, - db_type :: String } + _db_injuries_detail_listings_id :: DefaultKey InjuriesDetailListing, + _db_player_id :: Int, + _db_date :: UTCTime, + _db_pos :: String, + _db_name :: String, + _db_injury :: String, + _db_status :: String, + _db_fantasy :: Maybe String, -- ^ Nobody knows what this is. + _db_injured :: Bool, + _db_type :: String } + deriving ( GHC.Generic ) + +-- | For 'H.cons', 'H.tail', etc. +-- +instance H.HVector InjuriesDetailListingPlayerListing instance ToDb InjuriesDetailListingPlayerListingXml where @@ -270,18 +278,12 @@ instance FromXmlFk InjuriesDetailListingPlayerListingXml where -- 'InjuriesDetailListingPlayerListingXml' we need to supply a -- foreign key to an 'InjuriesDetailListing'. -- - from_xml_fk fk InjuriesDetailListingPlayerListingXml{..} = - InjuriesDetailListingPlayerListing { - db_injuries_detail_listings_id = fk, - db_player_id = xml_player_id, - db_date = xml_date, - db_pos = xml_pos, - db_name = xml_name, - db_injury = xml_injury, - db_status = xml_status, - db_fantasy = xml_fantasy, - db_injured = xml_injured, - db_type = xml_type } + from_xml_fk fk = (H.cons fk) . asCont . H.tail + where + -- Should be in the library soon. + asCont :: H.ContVec a -> H.ContVec a + asCont = id + -- | This lets us insert the XML representation -- 'InjuriesDetailListingPlayerListingXml' directly. @@ -339,7 +341,7 @@ mkPersist tsn_codegen_config [groundhog| constructors: - name: InjuriesDetailListingPlayerListing fields: - - name: db_injuries_detail_listings_id + - name: _db_injuries_detail_listings_id reference: onDelete: cascade |] @@ -355,7 +357,7 @@ mkPersist tsn_codegen_config [groundhog| pickle_player_listing :: PU InjuriesDetailListingPlayerListingXml pickle_player_listing = xpElem "PlayerListing" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xp10Tuple (xpElem "TeamID" xpText) (xpElem "PlayerID" xpInt) (xpElem "Date" xp_date) @@ -375,7 +377,7 @@ pickle_player_listing = pickle_listing :: PU InjuriesDetailListingXml pickle_listing = xpElem "Listing" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xpTriple (xpElem "TeamID" xpText) (xpElem "FullName" xpText) (xpList pickle_player_listing) @@ -388,7 +390,7 @@ pickle_listing = pickle_message :: PU Message pickle_message = xpElem "message" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xp6Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "category" xpText) -- 2.44.2