X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FWeather.hs;h=1d17fb017ba130522df58c217f70ee82b0798b8b;hb=819ac1c4b1f16bde572728d76bfd72282d0605ec;hp=0866f6f09ee7a666f54da7cb4ce47e1f60e8c47a;hpb=fe55e0de738d00b94ad1269bafe32beb83860387;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/XML/Weather.hs b/src/TSN/XML/Weather.hs
index 0866f6f..1d17fb0 100644
--- a/src/TSN/XML/Weather.hs
+++ b/src/TSN/XML/Weather.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE QuasiQuotes #-}
@@ -40,6 +41,7 @@ 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.XML.HXT.Core (
@@ -52,10 +54,8 @@ import Text.XML.HXT.Core (
   filterAxis,
   followingSiblingAxis,
   hasName,
-  readDocument,
   remNav,
   runLA,
-  runX,
   xp8Tuple,
   xp9Tuple,
   xpAttr,
@@ -69,6 +69,7 @@ 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 )
@@ -79,9 +80,9 @@ import Xml (
   FromXml(..),
   FromXmlFk(..),
   ToDb(..),
-  parse_opts,
   pickle_unpickle,
   unpickleable,
+  unsafe_read_document,
   unsafe_unpickle )
 
 
@@ -103,8 +104,13 @@ dtd = "weatherxml.dtd"
 data WeatherForecastListingXml =
   WeatherForecastListingXml {
     xml_teams :: String,
-    xml_weather :: String }
-  deriving (Eq, Show)
+    xml_weather :: Maybe String }
+  deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'Generics.to_tuple'.
+--
+instance Generic WeatherForecastListingXml
 
 
 -- | Database representation of a weather forecast listing. The
@@ -116,7 +122,7 @@ data WeatherForecastListing =
     db_weather_forecasts_id :: DefaultKey WeatherForecast,
     db_league_name :: Maybe String,
     db_teams :: String,
-    db_weather :: String }
+    db_weather :: Maybe String }
 
 
 -- | We don't make 'WeatherForecastListingXml' an instance of
@@ -169,7 +175,12 @@ data WeatherForecastXml =
   WeatherForecastXml {
     xml_game_date :: UTCTime,
     xml_leagues :: [WeatherLeague] }
-  deriving (Eq, Show)
+  deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'Generics.to_tuple'.
+--
+instance Generic WeatherForecastXml
 
 
 instance ToDb WeatherForecastXml where
@@ -224,11 +235,26 @@ data WeatherDetailedWeatherXml =
 --   present in each \<Item\>s.
 --
 data WeatherDetailedWeatherListingXml =
-  WeatherDetailedWeatherListingXml {
-    xml_dtl_listing_sport :: String,
-    xml_dtl_listing_sport_code :: String,
-    xml_items :: [WeatherDetailedWeatherListingItemXml] }
-  deriving (Eq, Show)
+  WeatherDetailedWeatherListingXml
+    String -- xml_dtl_listing_sport, unused
+    String -- xml_dtl_listing_sport_code, unused
+    [WeatherDetailedWeatherListingItemXml] -- xml_items
+  deriving (Eq, GHC.Generic, Show)
+
+
+-- | Accessor for the third field of WeatherDetailedWeatherListingXml.
+--   We don't use field names to avoid the unused field warnings that
+--   we'd otherwise get for the first two fields.
+--
+xml_items :: WeatherDetailedWeatherListingXml
+          -> [WeatherDetailedWeatherListingItemXml]
+xml_items (WeatherDetailedWeatherListingXml _ _ items) = items
+
+
+-- | For 'Generics.to_tuple'.
+--
+instance Generic WeatherDetailedWeatherListingXml
+
 
 -- * WeatherDetailedWeatherListingItem / WeatherDetailedWeatherListingItemXml
 
@@ -249,7 +275,7 @@ data WeatherDetailedWeatherListingItem =
     db_away_team :: String,
     db_home_team :: String,
     db_weather_type :: Int,
-    db_description :: String,
+    db_description :: Maybe String,
     db_temp_adjust :: Maybe String,
     db_temperature :: Int }
 
@@ -265,12 +291,16 @@ data WeatherDetailedWeatherListingItemXml =
     xml_away_team :: String,
     xml_home_team :: String,
     xml_weather_type :: Int,
-    xml_description :: String,
+    xml_description :: Maybe String,
     xml_temp_adjust :: Maybe String,
     xml_temperature :: Int }
-  deriving (Eq, Show)
+  deriving (Eq, GHC.Generic, Show)
 
 
+-- | For 'Generics.to_tuple'.
+--
+instance Generic WeatherDetailedWeatherListingItemXml
+
 instance ToDb WeatherDetailedWeatherListingItemXml where
   -- | Our database analogue is a 'WeatherDetailedWeatherListingItem'.
   type Db WeatherDetailedWeatherListingItemXml =
@@ -328,7 +358,13 @@ data Message =
     xml_forecasts :: [WeatherForecastXml],
     xml_detailed_weather :: Maybe WeatherDetailedWeatherXml,
     xml_time_stamp :: UTCTime }
-  deriving (Eq, Show)
+  deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'Generics.to_tuple'.
+--
+instance Generic Message
+
 
 instance ToDb Message where
   -- | The database representation of 'Message' is 'Weather'.
@@ -384,7 +420,8 @@ mkPersist tsn_codegen_config [groundhog|
           reference:
             onDelete: cascade
 
-# We rename the two fields that needed a "dtl" prefix to avoid a name clash.
+  # We rename the two fields that needed a "dtl" prefix to avoid a name
+  # clash.
 - entity: WeatherDetailedWeatherListingItem
   dbName: weather_detailed_items
   constructors:
@@ -484,6 +521,14 @@ instance DbImport Message where
         -- And finally, insert those DB listings.
         mapM_ insert_ db_listings
 
+    -- Now we do the detailed weather items.
+    case (xml_detailed_weather m) of
+      Nothing -> return ()
+      Just dw -> do
+        let detailed_listings = xml_detailed_listings dw
+        let items = concatMap xml_items detailed_listings
+        mapM_ (insert_xml_fk_ weather_id) items
+
     return ImportSucceeded
 
 
@@ -496,13 +541,13 @@ instance DbImport Message where
 pickle_listing :: PU WeatherForecastListingXml
 pickle_listing =
   xpElem "listing" $
-    xpWrap (from_pair, to_pair) $
+    xpWrap (from_pair, to_tuple) $
       xpPair
         (xpElem "teams" xpText)
-        (xpElem "weather" xpText)
+        (xpElem "weather" (xpOption xpText))
   where
     from_pair = uncurry WeatherForecastListingXml
-    to_pair WeatherForecastListingXml{..} = (xml_teams, xml_weather)
+
 
 
 -- | Pickler to convert a 'WeatherLeague' to/from XML.
@@ -547,20 +592,12 @@ pickle_item =
              (xpElem "AwayTeam" xpText)
              (xpElem "HomeTeam" xpText)
              (xpElem "WeatherType" xpInt)
-             (xpElem "Description" xpText)
+             (xpElem "Description" (xpOption xpText))
              (xpElem "TempAdjust" (xpOption xpText))
              (xpElem "Temperature" xpInt)
   where
     from_tuple = uncurryN WeatherDetailedWeatherListingItemXml
-    to_tuple w = (xml_sport_code w,
-                  xml_game_id w,
-                  xml_dtl_game_date w,
-                  xml_away_team w,
-                  xml_home_team w,
-                  xml_weather_type w,
-                  xml_description w,
-                  xml_temp_adjust w,
-                  xml_temperature w)
+
 
 
 -- | (Un)pickle a 'WeatherDetailedWeatherListingXml'.
@@ -574,9 +611,6 @@ pickle_dw_listing =
              (xpList pickle_item)
   where
     from_tuple = uncurryN WeatherDetailedWeatherListingXml
-    to_tuple w = (xml_dtl_listing_sport w,
-                  xml_dtl_listing_sport_code w,
-                  xml_items w)
 
 
 -- | (Un)pickle a 'WeatherDetailedWeatherXml'
@@ -605,14 +639,6 @@ pickle_message =
         (xpElem "time_stamp" xp_time_stamp)
   where
     from_tuple = uncurryN Message
-    to_tuple Message{..} = (xml_xml_file_id,
-                            xml_heading,
-                            xml_category,
-                            xml_sport,
-                            xml_title,
-                            xml_forecasts,
-                            xml_detailed_weather,
-                            xml_time_stamp)
 
 
 --
@@ -653,7 +679,9 @@ test_unpickle_succeeds = testGroup "unpickle tests"
   [ check "unpickling succeeds"
           "test/xml/weatherxml.xml",
     check "unpickling succeeds (detailed)"
-          "test/xml/weatherxml-detailed.xml" ]
+          "test/xml/weatherxml-detailed.xml",
+    check "unpickling succeeds (empty weather)"
+          "test/xml/weatherxml-empty-weather.xml"]
   where
     check desc path = testCase desc $ do
       actual <- unpickleable path pickle_message
@@ -669,7 +697,9 @@ test_on_delete_cascade = testGroup "cascading delete tests"
   [ check "deleting weather deletes its children"
           "test/xml/weatherxml.xml",
     check "deleting weather deletes its children (detailed)"
-          "test/xml/weatherxml-detailed.xml" ]
+          "test/xml/weatherxml-detailed.xml",
+    check "deleting weather deletes its children (empty weather)"
+          "test/xml/weatherxml-empty-weather.xml"]
   where
     check desc path = testCase desc $ do
       weather <- unsafe_unpickle path pickle_message
@@ -694,31 +724,27 @@ test_on_delete_cascade = testGroup "cascading delete tests"
       actual @?= expected
 
 
--- | This is used in a few tests to extract an 'XmlTree' from a path.
---
-unsafe_get_xmltree :: String -> IO XmlTree
-unsafe_get_xmltree path =
-  fmap head $ runX $ readDocument parse_opts path
-
-
 -- | We want to make sure type1 documents are detected as type1, and
 --   type2 documents detected as type2..
 --
 test_types_detected_correctly :: TestTree
 test_types_detected_correctly =
-  testGroup "weatherxml types detected correctly" $
+  testGroup "weatherxml types detected correctly"
     [ check "test/xml/weatherxml.xml"
             "first type detected correctly"
             True,
       check "test/xml/weatherxml-detailed.xml"
             "first type detected correctly (detailed)"
             True,
+      check "test/xml/weatherxml-empty-weather.xml"
+            "first type detected correctly (empty weather)"
+            True,
       check "test/xml/weatherxml-type2.xml"
             "second type detected correctly"
             False ]
   where
     check path desc expected = testCase desc $ do
-      xmltree <- unsafe_get_xmltree path
+      xmltree <- unsafe_read_document path
       let actual = is_type1 xmltree
       actual @?= expected
 
@@ -739,6 +765,6 @@ test_normal_teams_detected_correctly =
           False ]
   where
     check desc path expected = testCase desc $ do
-      xmltree <- unsafe_get_xmltree path
+      xmltree <- unsafe_read_document path
       let actual = teams_are_normal xmltree
       actual @?= expected