From: Michael Orlitzky Date: Sat, 5 Jul 2014 16:18:37 +0000 (-0400) Subject: Move the weird weatherxml example out of schemagen/ and under doc/. X-Git-Tag: 0.0.6~32 X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=b2c39ebe5ff9c1ea3224231df5078c52d0ad8737;p=dead%2Fhtsn-import.git Move the weird weatherxml example out of schemagen/ and under doc/. Allow weather forecasts to contain multiple leagues. --- diff --git a/doc/man1/htsn-import.1 b/doc/man1/htsn-import.1 index aebfb06..5e3d5ac 100644 --- a/doc/man1/htsn-import.1 +++ b/doc/man1/htsn-import.1 @@ -300,7 +300,7 @@ There appear to be two types of weather documents; the first has contained within . While it would be possible to parse both, it would greatly complicate things. The first form is more common, so that's all we support for now. An example is provided as -schemagen/weatherxml/20143655.xml. +doc/xml-samples/weird-weatherxml.xml. .SH DEPLOYMENT .P diff --git a/schemagen/weatherxml/20143655.xml b/doc/xml-samples/weird-weatherxml.xml similarity index 100% rename from schemagen/weatherxml/20143655.xml rename to doc/xml-samples/weird-weatherxml.xml diff --git a/src/TSN/XML/Weather.hs b/src/TSN/XML/Weather.hs index be591c1..6df3ce3 100644 --- a/src/TSN/XML/Weather.hs +++ b/src/TSN/XML/Weather.hs @@ -6,8 +6,8 @@ {-# LANGUAGE TypeFamilies #-} -- | Parse TSN XML for the DTD \"weatherxml.dtd\". Each document --- contains a bunch of forecasts, which each contain one league, and --- that league contains a bunch of listings. +-- contains a bunch of forecasts, which each contain zero or more +-- leagues, which in turn (each) contain a bunch of listings. -- module TSN.XML.Weather ( dtd, @@ -27,6 +27,7 @@ import Data.Tuple.Curry ( uncurryN ) import Database.Groundhog ( countAll, deleteAll, + insert_, migrate, runMigration, silentMigrationLogger ) @@ -87,58 +88,50 @@ data WeatherForecastListingXml = xml_weather :: String } deriving (Eq, Show) --- | Database representation of a weather forecast listing. + +-- | Database representation of a weather forecast listing. The +-- 'db_league_name' field should come from the containing \ +-- element which is not stored in the database. -- data WeatherForecastListing = WeatherForecastListing { db_weather_forecasts_id :: DefaultKey WeatherForecast, + db_league_name :: Maybe String, db_teams :: String, db_weather :: String } --- | The database analogue of a 'WeatherForecastListingXml' is --- 'WeatherForecastListing'. +-- | We don't make 'WeatherForecastListingXml' an instance of +-- 'FromXmlFk' because it needs some additional information, namely +-- the league name from its containing \ element. -- -instance ToDb WeatherForecastListingXml where - type Db WeatherForecastListingXml = WeatherForecastListing - - -instance Child WeatherForecastListingXml where - -- | Each 'WeatherForecastListingXml' is contained in a - -- 'WeatherForecast'. - -- - type Parent WeatherForecastListingXml = WeatherForecast - - --- | This is needed to define the 'XmlImportFk' instance for --- 'WeatherForecastListing'. +-- When supplied with a forecast id and a league name, this will +-- turn an XML listing into a database one. -- -instance FromXmlFk WeatherForecastListingXml where - from_xml_fk fk WeatherForecastListingXml{..} = +from_xml_fk_league :: DefaultKey WeatherForecast + -> (Maybe String) + -> WeatherForecastListingXml + -> WeatherForecastListing +from_xml_fk_league fk ln WeatherForecastListingXml{..} = WeatherForecastListing { db_weather_forecasts_id = fk, + db_league_name = ln, db_teams = xml_teams, db_weather = xml_weather } --- | This allows us to insert the XML representation --- 'WeatherForecastListingXml' directly. --- -instance XmlImportFk WeatherForecastListingXml - -- * WeatherLeague -- | XML representation of a league, as they appear in the weather -- documents. There is no associated database representation because -- the league element really adds no information besides its own --- (usually empty) name. Since there's exactly one league per --- forecast, we just store the league_name in the database --- representation of a forecast. +-- (usually empty) name. The leagues contain listings, so we +-- associate the league name with each listing instead. -- data WeatherLeague = WeatherLeague { - league_name :: Maybe String, - listings :: [WeatherForecastListingXml] } + league_name :: Maybe String, + listings :: [WeatherForecastListingXml] } deriving (Eq, Show) @@ -149,19 +142,18 @@ data WeatherLeague = data WeatherForecast = WeatherForecast { db_weather_id :: DefaultKey Weather, - db_game_date :: UTCTime, - db_league_name :: Maybe String } + db_game_date :: UTCTime } + --- | XML representation of a weather forecast. It would have been --- cleaner to omit the 'WeatherLeague' middleman, but having it --- simplifies parsing. +-- | XML representation of a weather forecast. -- data WeatherForecastXml = WeatherForecastXml { xml_game_date :: UTCTime, - xml_league :: WeatherLeague } + xml_leagues :: [WeatherLeague] } deriving (Eq, Show) + instance ToDb WeatherForecastXml where -- | The database representation of a 'WeatherForecastXml' is a -- 'WeatherForecast'. @@ -178,13 +170,12 @@ instance Child WeatherForecastXml where instance FromXmlFk WeatherForecastXml where -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we - -- replace the 'WeatherLeague' with its name. + -- just copy everything verbatim. -- from_xml_fk fk WeatherForecastXml{..} = WeatherForecast { db_weather_id = fk, - db_game_date = xml_game_date, - db_league_name = (league_name xml_league) } + db_game_date = xml_game_date } -- | This allows us to call 'insert_xml' on an 'WeatherForecastXml' @@ -283,16 +274,25 @@ instance DbImport Message where migrate (undefined :: WeatherForecastListing) dbimport m = do - -- The weather database schema has a nice linear structure. First - -- we insert the top-level weather record. + -- First we insert the top-level weather record. weather_id <- insert_xml m -- Next insert all of the forecasts, one at a time. forM_ (xml_forecasts m) $ \forecast -> do forecast_id <- insert_xml_fk weather_id forecast - -- Insert all of this forecast's listings. - mapM_ (insert_xml_fk_ forecast_id) (listings $ xml_league forecast) + -- With the forecast id in hand, loop through this forecast's + -- leagues... + forM_ (xml_leagues forecast) $ \league -> do + -- Construct the function that converts an XML listing to a + -- database one. + let todb = from_xml_fk_league forecast_id (league_name league) + + -- Now use it to convert all of the XML listings. + let db_listings = map todb (listings league) + + -- And finally, insert those DB listings. + mapM_ insert_ db_listings return ImportSucceeded @@ -337,11 +337,11 @@ pickle_forecast = xpWrap (from_pair, to_pair) $ xpPair (xpAttr "gamedate" xp_gamedate) - pickle_league + (xpList pickle_league) where from_pair = uncurry WeatherForecastXml to_pair WeatherForecastXml{..} = (xml_game_date, - xml_league) + xml_leagues)