+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
dtd,
is_type1,
pickle_message,
+ teams_are_normal,
-- * Tests
weather_tests,
-- * WARNING: these are private but exported to silence warnings
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 (
PU,
XmlTree,
(/>),
+ (>>>),
+ addNav,
+ descendantAxis,
+ filterAxis,
+ followingSiblingAxis,
hasName,
- readDocument,
+ remNav,
runLA,
- runX,
xp8Tuple,
xp9Tuple,
xpAttr,
FromXml(..),
FromXmlFk(..),
ToDb(..),
- parse_opts,
pickle_unpickle,
unpickleable,
+ unsafe_read_document,
unsafe_unpickle )
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
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
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
instance FromXmlFk WeatherForecastXml where
-- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
- -- just copy everything verbatim.
+ -- 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 {
-- 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 'H.convert'.
+--
+instance H.HVector WeatherDetailedWeatherListingXml
+
-- * WeatherDetailedWeatherListingItem / WeatherDetailedWeatherListingItemXml
-- 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 :: 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 :: 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'.
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.
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'.
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
|]
elements = parse xmltree
+-- | Some weatherxml documents even have the Home/Away teams in the
+-- wrong order. We can't parse that! This next bit of voodoo detects
+-- whether or not there are any \<HomeTeam\> elements that are
+-- directly followed by sibling \<AwayTeam\> elements. This is the
+-- opposite of the usual order.
+--
+teams_are_normal :: XmlTree -> Bool
+teams_are_normal xmltree =
+ case elements of
+ [] -> True
+ _ -> False
+ where
+ parse :: XmlTree -> [XmlTree]
+ parse = runLA $ hasName "/"
+ /> hasName "message"
+ /> hasName "Detailed_Weather"
+ /> hasName "DW_Listing"
+ /> hasName "Item"
+ >>> addNav
+ >>> descendantAxis
+ >>> filterAxis (hasName "HomeTeam")
+ >>> followingSiblingAxis
+ >>> remNav
+ >>> hasName "AwayTeam"
+
+ elements = parse xmltree
+
+
instance DbImport Message where
dbmigrate _ =
run_dbmigrate $ do
-- 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
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.
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 "TempAdjust" 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'.
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'
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 "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)
--
[ test_on_delete_cascade,
test_pickle_of_unpickle_is_identity,
test_unpickle_succeeds,
- test_types_detected_correctly ]
+ test_types_detected_correctly,
+ test_normal_teams_detected_correctly ]
-- | If we unpickle something and then pickle it, we should wind up
[ 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
[ 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
let c = undefined :: WeatherForecastListing
let d = undefined :: WeatherDetailedWeatherListingItem
actual <- withSqliteConn ":memory:" $ runDbConn $ do
- runMigration silentMigrationLogger $ do
+ runMigrationSilent $ do
migrate a
migrate b
migrate c
actual @?= expected
+-- | 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
- unsafe_get_xmltree :: String -> IO XmlTree
- unsafe_get_xmltree path =
- fmap head $ runX $ readDocument parse_opts path
-
check path desc expected = testCase desc $ do
- xmltree <- unsafe_get_xmltree path
+ xmltree <- unsafe_read_document path
let actual = is_type1 xmltree
actual @?= expected
+
+
+-- | We want to make sure normal teams are detected as normal, and the
+-- backwards ones are flagged as backwards.
+--
+test_normal_teams_detected_correctly :: TestTree
+test_normal_teams_detected_correctly =
+ testGroup "team order is detected correctly" [
+
+ check "normal teams are detected correctly"
+ "test/xml/weatherxml.xml"
+ True,
+
+ check "backwards teams are detected correctly"
+ "test/xml/weatherxml-backwards-teams.xml"
+ False ]
+ where
+ check desc path expected = testCase desc $ do
+ xmltree <- unsafe_read_document path
+ let actual = teams_are_normal xmltree
+ actual @?= expected
projects / dead / htsn-import.git / blobdiff