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,
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 )
deriving (Eq, GHC.Generic, Show)
--- | For 'Generics.to_tuple'.
+-- | For 'H.convert'.
--
-instance Generic Message
+instance H.HVector Message
-- | Database representation of a 'Message'.
deriving (Eq, GHC.Generic, Show)
--- | For 'Generics.to_tuple'.
+-- | For 'H.convert'.
--
-instance Generic InjuriesDetailListingXml
+instance H.HVector InjuriesDetailListingXml
instance ToDb InjuriesDetailListingXml where
-- * InjuriesDetailListingPlayerListing
-- | XML representation of a \<PlayerListing\>, 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
-- 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
-- '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.
constructors:
- name: InjuriesDetailListingPlayerListing
fields:
- - name: db_injuries_detail_listings_id
+ - name: _db_injuries_detail_listings_id
reference:
onDelete: cascade
|]
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)
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)
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)