Migrate TSN.XML.AutoRacingSchedule to fixed-vector-hetero.

[dead/htsn-import.git] / src / TSN / XML / AutoRacingSchedule.hs

diff --git a/src/TSN/XML/AutoRacingSchedule.hs b/src/TSN/XML/AutoRacingSchedule.hs
index ab1c29ef01db05be044eabb0055eb91635558039..39cfeb9e111b9e7a8c5b51b4f5c8ebde64bacfd9 100644 (file)
--- a/src/TSN/XML/AutoRacingSchedule.hs
+++ b/src/TSN/XML/AutoRacingSchedule.hs
@@ -1,9 +1,10 @@
+

 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveDataTypeable #-}

+{-# LANGUAGE DeriveGeneric #-}

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

-{-# LANGUAGE StandaloneDeriving #-}

 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 


@@ -27,9 +28,10 @@ where
 import Control.Monad ( forM_ )
 import Data.Time ( UTCTime(..) )
 import Data.Tuple.Curry ( uncurryN )
 import Control.Monad ( forM_ )
 import Data.Time ( UTCTime(..) )
 import Data.Tuple.Curry ( uncurryN )

+import qualified Data.Vector.HFixed as H ( HVector, cons, convert )

 import Database.Groundhog (
   countAll,
 import Database.Groundhog (
   countAll,

-  executeRaw,
+  deleteAll,

   migrate,
   runMigration,
   silentMigrationLogger )
   migrate,
   runMigration,
   silentMigrationLogger )


@@ -39,6 +41,7 @@ import Database.Groundhog.Sqlite ( withSqliteConn )
 import Database.Groundhog.TH (
   groundhog,
   mkPersist )
 import Database.Groundhog.TH (
   groundhog,
   mkPersist )

+import qualified GHC.Generics as GHC ( Generic )

 import Test.Tasty ( TestTree, testGroup )
 import Test.Tasty.HUnit ( (@?=), testCase )
 import Text.XML.HXT.Core (
 import Test.Tasty ( TestTree, testGroup )
 import Test.Tasty.HUnit ( (@?=), testCase )
 import Text.XML.HXT.Core (


@@ -57,9 +60,10 @@ import Text.XML.HXT.Core (
 import TSN.Codegen (
   tsn_codegen_config )
 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
 import TSN.Codegen (
   tsn_codegen_config )
 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )

-import TSN.Picklers ( xp_date, xp_tba_time, xp_time_stamp )
+import TSN.Picklers ( xp_date_padded, xp_tba_time, xp_time_stamp )

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

+  Child(..),

   FromXml(..),
   FromXmlFk(..),
   ToDb(..),
   FromXml(..),
   FromXmlFk(..),
   ToDb(..),


@@ -105,7 +109,11 @@ data Message =
     xml_complete_through :: String,
     xml_listings :: [AutoRacingScheduleListingXml],
     xml_time_stamp :: UTCTime }
     xml_complete_through :: String,
     xml_listings :: [AutoRacingScheduleListingXml],
     xml_time_stamp :: UTCTime }

-  deriving (Eq, Show)
+  deriving (Eq, GHC.Generic, Show)
+
+-- | For 'H.convert'.
+--
+instance H.HVector Message

 
 
 instance ToDb Message where
 
 
 instance ToDb Message where


@@ -141,7 +149,7 @@ instance XmlImport Message
 -- * AutoRacingScheduleListing/AutoRacingScheduleListingXml
 
 -- | Database representation of a \<Listing\> contained within a
 -- * AutoRacingScheduleListing/AutoRacingScheduleListingXml
 
 -- | Database representation of a \<Listing\> contained within a

---   \<Message\>. We combine the race date/time into a single
+--   \<message\>. We combine the race date/time into a single

 --   race_time, drop the race results list, and add a foreign key to
 --   our parent.
 --
 --   race_time, drop the race results list, and add a foreign key to
 --   our parent.
 --


@@ -176,7 +184,11 @@ data AutoRacingScheduleListingXml =
                                 --   so we can't do the right thing and use
                                 --   a 'Double'.
     xml_race_results :: [AutoRacingScheduleListingRaceResult] }
                                 --   so we can't do the right thing and use
                                 --   a 'Double'.
     xml_race_results :: [AutoRacingScheduleListingRaceResult] }

-  deriving (Eq, Show)
+  deriving (Eq, GHC.Generic, Show)
+
+-- | For 'H.convert'.
+--
+instance H.HVector AutoRacingScheduleListingXml

 
 
 -- | Pseudo-accessor to get the race result listings out of a
 
 
 -- | Pseudo-accessor to get the race result listings out of a


@@ -193,12 +205,15 @@ instance ToDb AutoRacingScheduleListingXml where
   --
   type Db AutoRacingScheduleListingXml = AutoRacingScheduleListing
 
   --
   type Db AutoRacingScheduleListingXml = AutoRacingScheduleListing
 

-instance FromXmlFk AutoRacingScheduleListingXml where
+
+instance Child AutoRacingScheduleListingXml where

   -- | Each 'AutoRacingScheduleListingXml' is contained in (i.e. has a
   --   foreign key to) a 'AutoRacingSchedule'.
   --
   type Parent AutoRacingScheduleListingXml = AutoRacingSchedule
 
   -- | Each 'AutoRacingScheduleListingXml' is contained in (i.e. has a
   --   foreign key to) a 'AutoRacingSchedule'.
   --
   type Parent AutoRacingScheduleListingXml = AutoRacingSchedule
 

+
+instance FromXmlFk AutoRacingScheduleListingXml where

   -- | To convert an 'AutoRacingScheduleListingXml' to an
   --   'AutoRacingScheduleListing', we add the foreign key and drop
   --   the 'xml_race_results'. We also mash the date/time together
   -- | To convert an 'AutoRacingScheduleListingXml' to an
   --   'AutoRacingScheduleListing', we add the foreign key and drop
   --   the 'xml_race_results'. We also mash the date/time together


@@ -245,41 +260,53 @@ newtype AutoRacingScheduleListingRaceResult =
   deriving (Eq, Show)
 
 
   deriving (Eq, Show)
 
 

--- * AutoRacingScheduleListingRaceResultRaceResultListing /
---   AutoRacingScheduleListingRaceResultRaceResultListingXml
+-- * AutoRacingScheduleListingRaceResultRaceResultListing / AutoRacingScheduleListingRaceResultRaceResultListingXml

 --
 --   Sorry about the names yo.
 --
 
 -- | Database representation of \<RaceResultListing\> within
 --   \<RaceResults\> within \<Listing\> within... \<message\>!
 --
 --   Sorry about the names yo.
 --
 
 -- | Database representation of \<RaceResultListing\> within
 --   \<RaceResults\> within \<Listing\> within... \<message\>!

+--   The leading underscores prevent unused field warnings.

 --
 data AutoRacingScheduleListingRaceResultRaceResultListing =
   AutoRacingScheduleListingRaceResultRaceResultListing {
 --
 data AutoRacingScheduleListingRaceResultRaceResultListing =
   AutoRacingScheduleListingRaceResultRaceResultListing {

-    db_auto_racing_schedules_listings_id ::
+    _db_auto_racing_schedules_listings_id ::

       DefaultKey AutoRacingScheduleListing,
       DefaultKey AutoRacingScheduleListing,

-    db_finish_position :: Int,
-    db_driver_id :: Int,
-    db_name :: String,
-    db_leading_laps :: Int,
-    db_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field.
-    db_earnings :: String,  -- ^ This should be an Int, but can have commas.
-    db_status :: String }
+    _db_finish_position :: Int,
+    _db_driver_id :: Int,
+    _db_name :: String,
+    _db_leading_laps :: Int,
+    _db_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field.
+    _db_earnings :: String,  -- ^ This should be an Int, but can have commas.
+    _db_status :: Maybe String -- ^ They can be empty
+    }
+  deriving ( GHC.Generic )
+
+-- | For 'H.cons'.
+--
+instance H.HVector AutoRacingScheduleListingRaceResultRaceResultListing

 
 
 -- | XML Representation of an
 --   'AutoRacingScheduleListingRaceResultRaceResultListing'.
 
 
 -- | XML Representation of an
 --   'AutoRacingScheduleListingRaceResultRaceResultListing'.

+--   The leading underscores prevent unused field warnings.

 --
 data AutoRacingScheduleListingRaceResultRaceResultListingXml =
   AutoRacingScheduleListingRaceResultRaceResultListingXml {
 --
 data AutoRacingScheduleListingRaceResultRaceResultListingXml =
   AutoRacingScheduleListingRaceResultRaceResultListingXml {

-    xml_finish_position :: Int,
-    xml_driver_id :: Int,
-    xml_name :: String,
-    xml_leading_laps :: Int,
-    xml_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field.
-    xml_earnings :: String,  -- ^ Should be an 'Int', but can have commas.
-    xml_status :: String }
-  deriving (Eq, Show)
+    _xml_finish_position :: Int,
+    _xml_driver_id :: Int,
+    _xml_name :: String,
+    _xml_leading_laps :: Int,
+    _xml_listing_laps :: Int, -- ^ Avoids clash with race's \"laps\" field.
+    _xml_earnings :: String,  -- ^ Should be an 'Int', but can have commas.
+    _xml_status :: Maybe String -- ^ They can be empty
+    }
+  deriving (Eq, GHC.Generic, Show)
+
+-- | For 'H.convert'.
+--
+instance H.HVector AutoRacingScheduleListingRaceResultRaceResultListingXml

 
 
 instance ToDb AutoRacingScheduleListingRaceResultRaceResultListingXml where
 
 
 instance ToDb AutoRacingScheduleListingRaceResultRaceResultListingXml where


@@ -291,7 +318,7 @@ instance ToDb AutoRacingScheduleListingRaceResultRaceResultListingXml where
     AutoRacingScheduleListingRaceResultRaceResultListing
 
 
     AutoRacingScheduleListingRaceResultRaceResultListing
 
 

-instance FromXmlFk AutoRacingScheduleListingRaceResultRaceResultListingXml where
+instance Child AutoRacingScheduleListingRaceResultRaceResultListingXml where

   -- | Each 'AutoRacingScheduleListingRaceResultRaceResultListingXml'
   --   is contained in (i.e. has a foreign key to) an
   --   'AutoRacingScheduleListing'. We skip the intermediate
   -- | Each 'AutoRacingScheduleListingRaceResultRaceResultListingXml'
   --   is contained in (i.e. has a foreign key to) an
   --   'AutoRacingScheduleListing'. We skip the intermediate


@@ -300,21 +327,14 @@ instance FromXmlFk AutoRacingScheduleListingRaceResultRaceResultListingXml where
   type Parent AutoRacingScheduleListingRaceResultRaceResultListingXml =
     AutoRacingScheduleListing
 
   type Parent AutoRacingScheduleListingRaceResultRaceResultListingXml =
     AutoRacingScheduleListing
 

+
+instance FromXmlFk AutoRacingScheduleListingRaceResultRaceResultListingXml where

   -- | To convert an
   --   'AutoRacingScheduleListingRaceResultRaceResultListingXml' to an
   --   'AutoRacingScheduleListingRaceResultRaceResultListing', we just
   --   add the foreign key to the parent 'AutoRacingScheduleListing'.
   --
   -- | To convert an
   --   'AutoRacingScheduleListingRaceResultRaceResultListingXml' to an
   --   'AutoRacingScheduleListingRaceResultRaceResultListing', we just
   --   add the foreign key to the parent 'AutoRacingScheduleListing'.
   --

-  from_xml_fk fk AutoRacingScheduleListingRaceResultRaceResultListingXml{..} =
-    AutoRacingScheduleListingRaceResultRaceResultListing {
-      db_auto_racing_schedules_listings_id = fk,
-      db_finish_position = xml_finish_position,
-      db_driver_id = xml_driver_id,
-      db_name = xml_name,
-      db_leading_laps = xml_leading_laps,
-      db_listing_laps = xml_listing_laps,
-      db_earnings = xml_earnings,
-      db_status = xml_earnings }
+  from_xml_fk = H.cons

 
 
 -- | This allows us to insert the XML representation
 
 
 -- | This allows us to insert the XML representation


@@ -357,7 +377,7 @@ mkPersist tsn_codegen_config [groundhog|
   constructors:
     - name: AutoRacingSchedule
       uniques:
   constructors:
     - name: AutoRacingSchedule
       uniques:

-        - name: unique_auto_racing_schedule
+        - name: unique_auto_racing_schedules

           type: constraint
           # Prevent multiple imports of the same message.
           fields: [db_xml_file_id]
           type: constraint
           # Prevent multiple imports of the same message.
           fields: [db_xml_file_id]


@@ -376,7 +396,7 @@ mkPersist tsn_codegen_config [groundhog|
   constructors:
     - name: AutoRacingScheduleListingRaceResultRaceResultListing
       fields:
   constructors:
     - name: AutoRacingScheduleListingRaceResultRaceResultListing
       fields:

-        - name: db_auto_racing_schedules_listings_id
+        - name: _db_auto_racing_schedules_listings_id

           reference:
             onDelete: cascade
 |]
           reference:
             onDelete: cascade
 |]


@@ -392,7 +412,7 @@ mkPersist tsn_codegen_config [groundhog|
 pickle_message :: PU Message
 pickle_message =
   xpElem "message" $
 pickle_message :: PU Message
 pickle_message =
   xpElem "message" $

-    xpWrap (from_tuple, to_tuple) $
+    xpWrap (from_tuple, H.convert) $

     xp8Tuple (xpElem "XML_File_ID" xpInt)
              (xpElem "heading" xpText)
              (xpElem "category" xpText)
     xp8Tuple (xpElem "XML_File_ID" xpInt)
              (xpElem "heading" xpText)
              (xpElem "category" xpText)


@@ -403,14 +423,6 @@ 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_title m,
-                  xml_complete_through m,
-                  xml_listings m,
-                  xml_time_stamp m)

 
 
 -- | Convert an 'AutoRacingScheduleListingXml' to/from XML.
 
 
 -- | Convert an 'AutoRacingScheduleListingXml' to/from XML.


@@ -418,9 +430,9 @@ pickle_message =
 pickle_listing :: PU AutoRacingScheduleListingXml
 pickle_listing =
   xpElem "Listing" $
 pickle_listing :: PU AutoRacingScheduleListingXml
 pickle_listing =
   xpElem "Listing" $

-    xpWrap (from_tuple, to_tuple) $
+    xpWrap (from_tuple, H.convert) $

       xp10Tuple (xpElem "RaceID" xpInt)
       xp10Tuple (xpElem "RaceID" xpInt)

-                (xpElem "Race_Date" xp_date)
+                (xpElem "Race_Date" xp_date_padded)

                 (xpElem "Race_Time" xp_tba_time)
                 (xpElem "RaceName" xpText)
                 (xpElem "TrackName" xpText)
                 (xpElem "Race_Time" xp_tba_time)
                 (xpElem "RaceName" xpText)
                 (xpElem "TrackName" xpText)


@@ -431,16 +443,7 @@ pickle_listing =
                 (xpList pickle_race_results)
   where
     from_tuple = uncurryN AutoRacingScheduleListingXml
                 (xpList pickle_race_results)
   where
     from_tuple = uncurryN AutoRacingScheduleListingXml

-    to_tuple m = (xml_race_id m,
-                  xml_race_date m,
-                  xml_race_time m,
-                  xml_race_name m,
-                  xml_track_name m,
-                  xml_location m,
-                  xml_tv_listing m,
-                  xml_laps m,
-                  xml_track_length m,
-                  xml_race_results m)
+

 
 
 -- | Convert an 'AutoRacingScheduleListingRaceResult' to/from XML.
 
 
 -- | Convert an 'AutoRacingScheduleListingRaceResult' to/from XML.


@@ -463,26 +466,18 @@ pickle_race_results_listing ::
   PU AutoRacingScheduleListingRaceResultRaceResultListingXml
 pickle_race_results_listing =
   xpElem "RaceResultsListing" $
   PU AutoRacingScheduleListingRaceResultRaceResultListingXml
 pickle_race_results_listing =
   xpElem "RaceResultsListing" $

-    xpWrap (from_tuple, to_tuple) $
+    xpWrap (from_tuple, H.convert) $

       xp7Tuple (xpElem "FinishPosition" xpInt)
                (xpElem "DriverID" xpInt)
                (xpElem "Name" xpText)
                (xpElem "LeadingLaps" xpInt)
                (xpElem "Laps" xpInt)
                (xpElem "Earnings" xpText)
       xp7Tuple (xpElem "FinishPosition" xpInt)
                (xpElem "DriverID" xpInt)
                (xpElem "Name" xpText)
                (xpElem "LeadingLaps" xpInt)
                (xpElem "Laps" xpInt)
                (xpElem "Earnings" xpText)

-               (xpElem "Status" xpText)
+               (xpElem "Status" (xpOption xpText))

   where
     from_tuple =
       uncurryN AutoRacingScheduleListingRaceResultRaceResultListingXml
 
   where
     from_tuple =
       uncurryN AutoRacingScheduleListingRaceResultRaceResultListingXml
 

-    to_tuple m = (xml_finish_position m,
-                  xml_driver_id m,
-                  xml_name m,
-                  xml_leading_laps m,
-                  xml_listing_laps m,
-                  xml_earnings m,
-                  xml_status m)
-

 
 --
 -- Tasty Tests
 
 --
 -- Tasty Tests


@@ -555,8 +550,7 @@ test_on_delete_cascade = testGroup "cascading delete tests"
                     migrate b
                     migrate c
                   _ <- dbimport sched
                     migrate b
                     migrate c
                   _ <- dbimport sched

-                  -- No idea how 'delete' works, so do this instead.
-                  executeRaw False "DELETE FROM auto_racing_schedules;" []
+                  deleteAll a

                   count_a <- countAll a
                   count_b <- countAll b
                   count_c <- countAll c
                   count_a <- countAll a
                   count_b <- countAll b
                   count_c <- countAll c