X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FInjuries.hs;h=85b7beefd0296d53670a9439cff338e676a8b0d7;hb=6fb74d99ca4eebbd8ca624c64b4f4cf707afad8f;hp=81243e44f20f8edd0dbd0f77a46c992379b2132f;hpb=4595387816651b26e4c163e5c416c5caa01d17cf;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/XML/Injuries.hs b/src/TSN/XML/Injuries.hs
index 81243e4..85b7bee 100644
--- a/src/TSN/XML/Injuries.hs
+++ b/src/TSN/XML/Injuries.hs
@@ -1,9 +1,9 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 
@@ -17,6 +17,7 @@
 --   time_stamp.
 --
 module TSN.XML.Injuries (
+  dtd,
   pickle_message,
   -- * Tests
   injuries_tests,
@@ -29,9 +30,10 @@ where
 import Data.Data ( Data )
 import Data.Time ( UTCTime )
 import Data.Typeable ( Typeable )
+import qualified Data.Vector.HFixed as H ( HVector, cons, convert )
 import Database.Groundhog (
   countAll,
-  executeRaw,
+  deleteAll,
   migrate,
   runMigration,
   silentMigrationLogger )
@@ -40,6 +42,7 @@ import Database.Groundhog.Generic ( runDbConn )
 import Database.Groundhog.TH (
   groundhog,
   mkPersist )
+import qualified GHC.Generics as GHC ( Generic )
 import Database.Groundhog.Sqlite ( withSqliteConn )
 import Data.Tuple.Curry ( uncurryN )
 import Test.Tasty ( TestTree, testGroup )
@@ -64,6 +67,7 @@ import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
 import TSN.Picklers ( xp_time_stamp )
 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
 import Xml (
+  Child(..),
   FromXml(..),
   FromXmlFk(..),
   ToDb(..),
@@ -72,6 +76,12 @@ import Xml (
   unsafe_unpickle )
 
 
+
+-- | The DTD to which this module corresponds. Used to invoke dbimport.
+--
+dtd :: String
+dtd = "injuriesxml.dtd"
+
 --
 -- DB/XML Data types
 --
@@ -90,45 +100,53 @@ data InjuriesTeam =
 
 -- * InjuriesListing/InjuriesListingXml
 
--- | XML representation of the injury listings.
+-- | XML representation of the injury listings. The leading
+--   underscores prevent unused field warnings.
 --
 data InjuriesListingXml =
   InjuriesListingXml {
-    xml_team :: InjuriesTeam,
-    xml_teamno :: Maybe Int,
-    xml_injuries :: String,
-    xml_updated :: Maybe Bool }
-  deriving (Eq, Show)
+    _xml_team :: InjuriesTeam,
+    _xml_teamno :: Maybe String, -- ^ Can contain non-numerics, e.g. \"ZR2\"
+    _xml_injuries :: String,
+    _xml_updated :: Maybe Bool }
+  deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector InjuriesListingXml
+
 
 -- | Database representation of a 'InjuriesListing'. It possesses a
 --   foreign key to an 'Injuries' object so that we can easily delete
 --   'InjuriesListing's based on the parent message's time_stamp.
+--   The leading underscores prevent unused field warnings.
 --
 data InjuriesListing =
   InjuriesListing {
-    db_injuries_id :: DefaultKey Injuries,
-    db_team :: InjuriesTeam,
-    db_teamno :: Maybe Int,
-    db_injuries :: String,
-    db_updated :: Maybe Bool }
+    _db_injuries_id :: DefaultKey Injuries,
+    _db_team :: InjuriesTeam,
+    _db_teamno :: Maybe String, -- ^ Can contain non-numerics, e.g. \"ZR2\"
+    _db_injuries :: String,
+    _db_updated :: Maybe Bool }
+  deriving ( GHC.Generic )
+
+-- | For 'H.cons'.
+--
+instance H.HVector InjuriesListing
 
 instance ToDb InjuriesListingXml where
   -- | The DB analogue of a 'InjuriesListingXml' is a 'InjuriesListing'
   type Db InjuriesListingXml = InjuriesListing
 
-instance FromXmlFk InjuriesListingXml where
+instance Child InjuriesListingXml where
   -- | Our foreign key points to an 'Injuries'.
   type Parent InjuriesListingXml = Injuries
 
+instance FromXmlFk InjuriesListingXml where
   -- | To convert between a 'InjuriesListingXml' and a
   --   'InjuriesListing', we simply append the foreign key.
-  from_xml_fk fk InjuriesListingXml{..} =
-    InjuriesListing {
-      db_injuries_id = fk,
-      db_team = xml_team,
-      db_teamno = xml_teamno,
-      db_injuries = xml_injuries,
-      db_updated = xml_updated }
+  from_xml_fk = H.cons
 
 -- | This allows us to insert the XML representation
 --   'InjuriesListingXml' directly.
@@ -148,7 +166,13 @@ data Message =
     xml_sport :: String,
     xml_listings :: [InjuriesListingXml],
     xml_time_stamp :: UTCTime }
-  deriving (Eq, Show)
+  deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.HVector'.
+--
+instance H.HVector Message
+
 
 -- | Database representation of a 'Message'.
 --
@@ -216,11 +240,11 @@ mkPersist tsn_codegen_config [groundhog|
   constructors:
     - name: InjuriesListing
       fields:
-        - name: db_team
+        - name: _db_team
           embeddedType:
             - {name: team_name, dbName: team_name}
             - {name: team_league, dbName: team_league}
-        - name: db_injuries_id
+        - name: _db_injuries_id
           reference:
             onDelete: cascade
 
@@ -241,12 +265,13 @@ mkPersist tsn_codegen_config [groundhog|
 pickle_injuries_team :: PU InjuriesTeam
 pickle_injuries_team =
   xpElem "team" $
-    xpWrap (from_tuple, to_tuple) $
+    xpWrap (from_tuple, to_tuple') $
     xpPair xpText (xpAttrImplied "league" xpText)
   where
     from_tuple = uncurryN InjuriesTeam
-    to_tuple m = (db_team_name m, db_team_league m)
 
+    -- Pointless, but silences two unused field warnings.
+    to_tuple' InjuriesTeam{..} = (db_team_name, db_team_league)
 
 -- | A pickler for 'InjuriesListingXml's that can convert them to/from
 --   XML.
@@ -254,14 +279,14 @@ pickle_injuries_team =
 pickle_listing :: PU InjuriesListingXml
 pickle_listing =
   xpElem "listing" $
-    xpWrap (from_tuple, to_tuple) $
+    xpWrap (from_tuple, H.convert) $
     xp4Tuple pickle_injuries_team
-             (xpOption $ xpElem "teamno" xpInt)
+             (xpOption $ xpElem "teamno" xpText)
              (xpElem "injuries" xpText)
              (xpOption $ xpElem "updated" xpPrim)
   where
     from_tuple = uncurryN InjuriesListingXml
-    to_tuple l = (xml_team l, xml_teamno l, xml_injuries l, xml_updated l)
+
 
 
 -- | A pickler for 'Message's that can convert them to/from XML.
@@ -269,7 +294,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)
@@ -278,12 +303,6 @@ 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_listings m,
-                  xml_time_stamp m)
 
 
 --
@@ -339,8 +358,7 @@ test_on_delete_cascade =
                   migrate a
                   migrate b
                 _ <- dbimport inj
-                -- No idea how 'delete' works, so do this instead.
-                executeRaw False "DELETE FROM injuries;" []
+                deleteAll a
                 count_a <- countAll a
                 count_b <- countAll b
                 return $ count_a + count_b