X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FWeather.hs;h=2f3a3ca2b2d32a8759083b13ffa675338393978d;hb=32147474ba5c91452eeb532381f63e88c257a982;hp=26935cf83b84068a49001e4f700170ed348dbd2f;hpb=7e1865e656ebbbba9566c7ace61176635fdeabe5;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/Weather.hs b/src/TSN/XML/Weather.hs index 26935cf..2f3a3ca 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 #-} @@ -27,19 +28,19 @@ where 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, deleteAll, insert_, - migrate, - runMigration, - silentMigrationLogger ) + migrate ) 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.XML.HXT.Core ( @@ -52,10 +53,8 @@ import Text.XML.HXT.Core ( filterAxis, followingSiblingAxis, hasName, - readDocument, remNav, runLA, - runX, xp8Tuple, xp9Tuple, xpAttr, @@ -79,9 +78,9 @@ import Xml ( FromXml(..), FromXmlFk(..), ToDb(..), - parse_opts, pickle_unpickle, unpickleable, + unsafe_read_document, unsafe_unpickle ) @@ -103,8 +102,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 'H.convert'. +-- +instance H.HVector WeatherForecastListingXml -- | Database representation of a weather forecast listing. The @@ -116,7 +120,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 +173,12 @@ data WeatherForecastXml = WeatherForecastXml { xml_game_date :: UTCTime, xml_leagues :: [WeatherLeague] } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector WeatherForecastXml instance ToDb WeatherForecastXml where @@ -191,6 +200,8 @@ instance FromXmlFk WeatherForecastXml where -- add the foreign key to the containing 'Weather', and copy the -- game date. -- + -- This is so short it's pointless to do it generically. + -- from_xml_fk fk WeatherForecastXml{..} = WeatherForecast { db_weather_id = fk, @@ -224,11 +235,26 @@ data WeatherDetailedWeatherXml = -- present in each \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 'H.convert'. +-- +instance H.HVector WeatherDetailedWeatherListingXml + -- * WeatherDetailedWeatherListingItem / WeatherDetailedWeatherListingItemXml @@ -239,38 +265,52 @@ data WeatherDetailedWeatherListingXml = -- We also drop the sport name, because it's given in the parent -- 'Weather'. -- +-- The leading underscores prevent unused field warnings. +-- data WeatherDetailedWeatherListingItem = WeatherDetailedWeatherListingItem { - db_dtl_weather_id :: DefaultKey Weather, -- ^ Avoid name collision by + _db_dtl_weather_id :: DefaultKey Weather, -- ^ Avoid name collision by -- using \"dtl\" prefix. - db_sport_code :: String, - db_game_id :: Int, - db_dtl_game_date :: UTCTime, -- ^ Avoid name clash with \"dtl\" prefix - db_away_team :: String, - db_home_team :: String, - db_weather_type :: Int, - db_description :: String, - db_temp_adjust :: Maybe String, - db_temperature :: Int } + _db_sport_code :: String, + _db_game_id :: Int, + _db_dtl_game_date :: UTCTime, -- ^ Avoid name clash with \"dtl\" prefix + _db_away_team :: String, + _db_home_team :: String, + _db_weather_type :: Int, + _db_description :: Maybe String, + _db_temp_adjust :: Maybe String, + _db_temperature :: Int } + deriving ( GHC.Generic ) + +-- | For 'H.cons' and 'H.convert'. +-- +instance H.HVector WeatherDetailedWeatherListingItem -- | XML representation of a detailed weather item. Same as the -- database representation, only without the foreign key and the -- sport name that comes from the containing listing. +-- +-- The leading underscores prevent unused field warnings. +-- data WeatherDetailedWeatherListingItemXml = WeatherDetailedWeatherListingItemXml { - xml_sport_code :: String, - xml_game_id :: Int, - xml_dtl_game_date :: UTCTime, - xml_away_team :: String, - xml_home_team :: String, - xml_weather_type :: Int, - xml_description :: String, - xml_temp_adjust :: Maybe String, - xml_temperature :: Int } - deriving (Eq, Show) + _xml_sport_code :: String, + _xml_game_id :: Int, + _xml_dtl_game_date :: UTCTime, + _xml_away_team :: String, + _xml_home_team :: String, + _xml_weather_type :: Int, + _xml_description :: Maybe String, + _xml_temp_adjust :: Maybe String, + _xml_temperature :: Int } + deriving (Eq, GHC.Generic, Show) +-- | For 'H.convert'. +-- +instance H.HVector WeatherDetailedWeatherListingItemXml + instance ToDb WeatherDetailedWeatherListingItemXml where -- | Our database analogue is a 'WeatherDetailedWeatherListingItem'. type Db WeatherDetailedWeatherListingItemXml = @@ -284,18 +324,7 @@ instance Child WeatherDetailedWeatherListingItemXml where instance FromXmlFk WeatherDetailedWeatherListingItemXml where -- | To convert from the XML to database representation, we simply -- add the foreign key (to Weather) and copy the rest of the fields. - from_xml_fk fk WeatherDetailedWeatherListingItemXml{..} = - WeatherDetailedWeatherListingItem { - db_dtl_weather_id = fk, - db_sport_code = xml_sport_code, - db_game_id = xml_game_id, - db_dtl_game_date = xml_dtl_game_date, - db_away_team = xml_away_team, - db_home_team = xml_home_team, - db_weather_type = xml_weather_type, - db_description = xml_description, - db_temp_adjust = xml_temp_adjust, - db_temperature = xml_temperature } + from_xml_fk = H.cons -- | This allows us to insert the XML representation directly without -- having to do the manual XML -\> DB conversion. @@ -328,7 +357,13 @@ data Message = xml_forecasts :: [WeatherForecastXml], xml_detailed_weather :: Maybe WeatherDetailedWeatherXml, xml_time_stamp :: UTCTime } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector Message + instance ToDb Message where -- | The database representation of 'Message' is 'Weather'. @@ -384,17 +419,18 @@ 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: - name: WeatherDetailedWeatherListingItem fields: - - name: db_dtl_weather_id + - name: _db_dtl_weather_id dbName: weather_id reference: onDelete: cascade - - name: db_dtl_game_date + - name: _db_dtl_game_date dbName: game_date |] @@ -504,13 +540,13 @@ instance DbImport Message where pickle_listing :: PU WeatherForecastListingXml pickle_listing = xpElem "listing" $ - xpWrap (from_pair, to_pair) $ + xpWrap (from_pair, H.convert) $ 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. @@ -548,27 +584,19 @@ pickle_forecast = pickle_item :: PU WeatherDetailedWeatherListingItemXml pickle_item = xpElem "Item" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xp9Tuple (xpElem "Sportcode" xpText) (xpElem "GameID" xpInt) (xpElem "Gamedate" xp_datetime) (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'. @@ -576,15 +604,12 @@ pickle_item = pickle_dw_listing :: PU WeatherDetailedWeatherListingXml pickle_dw_listing = xpElem "DW_Listing" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xpTriple (xpAttr "SportCode" xpText) (xpAttr "Sport" xpText) (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' @@ -601,7 +626,7 @@ pickle_detailed_weather = 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) @@ -613,14 +638,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) -- @@ -661,7 +678,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 @@ -677,7 +696,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 @@ -686,7 +707,7 @@ test_on_delete_cascade = testGroup "cascading delete tests" let c = undefined :: WeatherForecastListing let d = undefined :: WeatherDetailedWeatherListingItem actual <- withSqliteConn ":memory:" $ runDbConn $ do - runMigration silentMigrationLogger $ do + runMigrationSilent $ do migrate a migrate b migrate c @@ -702,31 +723,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 @@ -747,6 +764,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