X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FOdds.hs;h=a07f4308c34d85e6205cb4a4b8f84d44162a4d33;hb=f9a9d6fdcdd2ee0e6bb1882ed2eba936535a52ac;hp=128b5b455160778ef09b1333fb7b24460729fb18;hpb=52936576e494b8cd7b764a1f436cd8b426714c8d;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/XML/Odds.hs b/src/TSN/XML/Odds.hs
index 128b5b4..a07f430 100644
--- a/src/TSN/XML/Odds.hs
+++ b/src/TSN/XML/Odds.hs
@@ -1,6 +1,8 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -27,6 +29,7 @@ import Control.Applicative ( (<$>) )
 import Control.Monad ( forM_, join )
 import Data.Time ( UTCTime(..) )
 import Data.Tuple.Curry ( uncurryN )
+import qualified Data.Vector.HFixed as H ( HVector, convert )
 import Database.Groundhog (
   (=.),
   (==.),
@@ -34,15 +37,14 @@ import Database.Groundhog (
   deleteAll,
   insert_,
   migrate,
-  runMigration,
-  silentMigrationLogger,
   update )
 import Database.Groundhog.Core ( DefaultKey )
-import Database.Groundhog.Generic ( runDbConn )
+import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
 import Database.Groundhog.Sqlite ( withSqliteConn )
 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.Read ( readMaybe )
@@ -64,7 +66,11 @@ import Text.XML.HXT.Core (
 import TSN.Codegen ( tsn_codegen_config )
 import TSN.Database ( insert_or_select )
 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
-import TSN.Picklers ( xp_date_padded, xp_tba_time, xp_time_stamp )
+import TSN.Picklers (
+  xp_attr_option,
+  xp_date_padded,
+  xp_tba_time,
+  xp_time_stamp )
 import TSN.Team ( FromXmlFkTeams(..), Team(..) )
 import TSN.XmlImport ( XmlImport(..), XmlImportFkTeams(..) )
 import Xml (
@@ -121,7 +127,12 @@ data OddsGameCasinoXml =
     xml_casino_client_id :: Maybe Int,
     xml_casino_name      :: Maybe String,
     xml_casino_line      :: Maybe String }
-  deriving (Eq, Show)
+  deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector OddsGameCasinoXml
 
 
 -- | Try to get a 'Double' out of the 'xml_casino_line' which is a
@@ -167,7 +178,12 @@ data OddsGameTeamStarterXml =
   OddsGameTeamStarterXml {
     xml_starter_id :: Int,
     xml_starter_name :: Maybe String }
-  deriving (Eq, Show)
+  deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector OddsGameTeamStarterXml
 
 
 -- | The XML representation of a \<HomeTeam\> or \<AwayTeam\>, as
@@ -189,7 +205,13 @@ data OddsGameTeamXml =
     xml_team_name            :: String,
     xml_team_starter         :: Maybe OddsGameTeamStarterXml,
     xml_team_casinos         :: [OddsGameCasinoXml] }
-  deriving (Eq, Show)
+  deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector OddsGameTeamXml
+
 
 instance ToDb OddsGameTeamXml where
   -- | The database representation of an 'OddsGameTeamXml' is an
@@ -279,7 +301,13 @@ data OddsGameXml =
     xml_away_team  :: OddsGameTeamXml,
     xml_home_team  :: OddsGameTeamXml,
     xml_over_under :: OddsGameOverUnderXml }
-  deriving (Eq, Show)
+  deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector OddsGameXml
+
 
 -- | Pseudo-field that lets us get the 'OddsGameCasinoXml's out of
 --   xml_over_under.
@@ -414,7 +442,12 @@ data Message =
     xml_line_time :: String,
     xml_games_with_notes :: [OddsGameWithNotes],
     xml_time_stamp :: UTCTime }
-  deriving (Eq, Show)
+  deriving (Eq, GHC.Generic, Show)
+
+-- | For 'H.convert'.
+--
+instance H.HVector Message
+
 
 -- | Pseudo-field that lets us get the 'OddsGame's out of
 --   'xml_games_with_notes'.
@@ -589,9 +622,10 @@ instance DbImport Message where
 
     where
       nonempty_casino :: OddsGameCasinoXml -> Bool
-      nonempty_casino (OddsGameCasinoXml Nothing _ _) = False
-      nonempty_casino (OddsGameCasinoXml _ Nothing _) = False
-      nonempty_casino _ = True
+      nonempty_casino OddsGameCasinoXml{..}
+        | Nothing <- xml_casino_client_id = False
+        | Nothing <- xml_casino_name = False
+        | otherwise = True
 
 --
 -- Pickling
@@ -616,17 +650,13 @@ pickle_game_with_notes =
 pickle_casino :: PU OddsGameCasinoXml
 pickle_casino =
   xpElem "Casino" $
-  xpWrap (from_tuple, to_tuple) $
+  xpWrap (from_tuple, H.convert) $
   xpTriple
-    (xpAttr "ClientID" $ xpOption xpInt)
+    (xpAttr "ClientID" xp_attr_option)
     (xpAttr "Name" $ xpOption xpText)
     (xpOption xpText)
   where
     from_tuple = uncurryN OddsGameCasinoXml
-    -- Use record wildcards to avoid unused field warnings.
-    to_tuple OddsGameCasinoXml{..} = (xml_casino_client_id,
-                                      xml_casino_name,
-                                      xml_casino_line)
 
 
 -- | Pickler for an 'OddsGameTeamXml'.
@@ -634,7 +664,7 @@ pickle_casino =
 pickle_home_team :: PU OddsGameTeamXml
 pickle_home_team =
   xpElem "HomeTeam" $
-    xpWrap (from_tuple, to_tuple) $
+    xpWrap (from_tuple, H.convert) $
       xp6Tuple
         (xpElem "HomeTeamID" xpText)
         (xpElem "HomeRotationNumber" (xpOption xpInt))
@@ -645,13 +675,6 @@ pickle_home_team =
   where
     from_tuple = uncurryN OddsGameTeamXml
 
-    -- Use record wildcards to avoid unused field warnings.
-    to_tuple OddsGameTeamXml{..} = (xml_team_id,
-                                    xml_team_rotation_number,
-                                    xml_team_abbr,
-                                    xml_team_name,
-                                    xml_team_starter,
-                                    xml_team_casinos)
 
 
 -- | Portion of the 'OddsGameTeamStarterXml' pickler that is not
@@ -659,12 +682,11 @@ pickle_home_team =
 --
 pickle_starter :: PU OddsGameTeamStarterXml
 pickle_starter =
-  xpWrap (from_tuple, to_tuple) $
+  xpWrap (from_tuple, H.convert) $
     xpPair (xpAttr "ID" xpInt) (xpOption xpText)
   where
     from_tuple = uncurry OddsGameTeamStarterXml
-    to_tuple OddsGameTeamStarterXml{..} = (xml_starter_id,
-                                           xml_starter_name)
+
 
 -- | Pickler for an home team 'OddsGameTeamStarterXml'
 --
@@ -684,7 +706,7 @@ pickle_away_starter = xpElem "AStarter" pickle_starter
 pickle_away_team :: PU OddsGameTeamXml
 pickle_away_team =
   xpElem "AwayTeam" $
-    xpWrap (from_tuple, to_tuple) $
+    xpWrap (from_tuple, H.convert) $
       xp6Tuple
         (xpElem "AwayTeamID" xpText)
         (xpElem "AwayRotationNumber" (xpOption xpInt))
@@ -695,14 +717,6 @@ pickle_away_team =
   where
     from_tuple = uncurryN OddsGameTeamXml
 
-    -- Use record wildcards to avoid unused field warnings.
-    to_tuple OddsGameTeamXml{..} = (xml_team_id,
-                                    xml_team_rotation_number,
-                                    xml_team_abbr,
-                                    xml_team_name,
-                                    xml_team_starter,
-                                    xml_team_casinos)
-
 
 
 -- | Pickler for an 'OddsGameOverUnderXml'.
@@ -722,7 +736,7 @@ pickle_over_under =
 pickle_game :: PU OddsGameXml
 pickle_game =
   xpElem "Game" $
-  xpWrap (from_tuple, to_tuple) $
+  xpWrap (from_tuple, H.convert) $
   xp6Tuple
     (xpElem "GameID" xpInt)
     (xpElem "Game_Date" xp_date_padded)
@@ -732,13 +746,6 @@ pickle_game =
     pickle_over_under
   where
     from_tuple = uncurryN OddsGameXml
-    -- Use record wildcards to avoid unused field warnings.
-    to_tuple OddsGameXml{..} = (xml_game_id,
-                                xml_game_date,
-                                xml_game_time,
-                                xml_away_team,
-                                xml_home_team,
-                                xml_over_under)
 
 
 -- | Pickler for the top-level 'Message'.
@@ -746,7 +753,7 @@ pickle_game =
 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)
@@ -757,14 +764,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_title m,
-                  xml_line_time m,
-                  xml_games_with_notes m,
-                  xml_time_stamp m)
 
 
 --
@@ -900,7 +899,7 @@ test_on_delete_cascade = testGroup "cascading delete tests"
       let d = undefined :: OddsGame
       let e = undefined :: OddsGameLine
       actual <- withSqliteConn ":memory:" $ runDbConn $ do
-                  runMigration silentMigrationLogger $ do
+                  runMigrationSilent $ do
                     migrate a
                     migrate b
                     migrate c