X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FWeather.hs;h=bda29ee2541005efb4ca1eaedcccf77d1231d201;hb=fa27649ae583f6bdc20c54db4fc8f38a382a536c;hp=3279ec81119cf16c231a9c178b1920918b881f86;hpb=7edcf71e0947bfa02f9d898ccdf74b96458ae852;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/XML/Weather.hs b/src/TSN/XML/Weather.hs
index 3279ec8..bda29ee 100644
--- a/src/TSN/XML/Weather.hs
+++ b/src/TSN/XML/Weather.hs
@@ -5,11 +5,12 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 
--- | Parse TSN XML for the DTD "weatherxml.dtd". Each document
+-- | 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.
 --
 module TSN.XML.Weather (
+  dtd,
   pickle_message,
   -- * Tests
   weather_tests,
@@ -23,8 +24,15 @@ where
 import Control.Monad ( forM_ )
 import Data.Time ( UTCTime )
 import Data.Tuple.Curry ( uncurryN )
-import Database.Groundhog ( migrate )
+import Database.Groundhog (
+  countAll,
+  deleteAll,
+  migrate,
+  runMigration,
+  silentMigrationLogger )
 import Database.Groundhog.Core ( DefaultKey )
+import Database.Groundhog.Generic ( runDbConn )
+import Database.Groundhog.Sqlite ( withSqliteConn )
 import Database.Groundhog.TH (
   groundhog,
   mkPersist )
@@ -53,13 +61,23 @@ import Xml (
   FromXmlFk(..),
   ToDb(..),
   pickle_unpickle,
-  unpickleable )
+  unpickleable,
+  unsafe_unpickle )
+
+
+
+-- | The DTD to which this module corresponds. Used to invoke dbimport.
+--
+dtd :: String
+dtd = "weatherxml.dtd"
 
 
 --
 -- DB/XML Data types
 --
 
+-- * WeatherForecastListing/WeatherForecastListingXml
+
 -- | XML representation of a weather forecast listing.
 --
 data WeatherForecastListingXml =
@@ -83,10 +101,13 @@ data WeatherForecastListing =
 instance ToDb WeatherForecastListingXml where
   type Db WeatherForecastListingXml = WeatherForecastListing
 
--- | This is needed to define the XmlImport instance for
--- 'WeatherForecastListing'.
+-- | This is needed to define the 'XmlImportFk' instance for
+--   'WeatherForecastListing'.
 --
 instance FromXmlFk WeatherForecastListingXml where
+  -- | Each 'WeatherForecastListingXml' is contained in a
+  --   'WeatherForecast'.
+  --
   type Parent WeatherForecastListingXml = WeatherForecast
 
   from_xml_fk fk WeatherForecastListingXml{..} =
@@ -95,12 +116,14 @@ instance FromXmlFk WeatherForecastListingXml where
       db_teams = xml_teams,
       db_weather = xml_weather }
 
--- | Allows us to call 'insert_xml' on the XML representation of
---   WeatherForecastListing.
+-- | 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
@@ -114,6 +137,9 @@ data WeatherLeague =
     listings :: [WeatherForecastListingXml] }
   deriving (Eq, Show)
 
+
+-- * WeatherForecast/WeatherForecastXml
+
 -- | Database representation of a weather forecast.
 --
 data WeatherForecast =
@@ -157,6 +183,8 @@ instance FromXmlFk WeatherForecastXml where
 instance XmlImportFk WeatherForecastXml
 
 
+-- * Weather/Message
+
 -- | The database representation of a weather message.
 --
 data Weather =
@@ -196,12 +224,16 @@ instance FromXml Message where
       db_title = xml_title,
       db_time_stamp = xml_time_stamp }
 
--- | This allows us to call 'insert_xml' on a 'Message' without first
---   converting it to the database representation.
+-- | This allows us to insert the XML representation 'Message'
+--   directly.
 --
 instance XmlImport Message
 
 
+--
+-- Database stuff
+--
+
 mkPersist tsn_codegen_config [groundhog|
 - entity: Weather
   constructors:
@@ -255,6 +287,9 @@ instance DbImport Message where
     return ImportSucceeded
 
 
+---
+--- Pickling
+---
 
 -- | Pickler to convert a 'WeatherForecastListingXml' to/from XML.
 --
@@ -332,7 +367,8 @@ weather_tests :: TestTree
 weather_tests =
   testGroup
     "Weather tests"
-    [ test_pickle_of_unpickle_is_identity,
+    [ test_on_delete_cascade,
+      test_pickle_of_unpickle_is_identity,
       test_unpickle_succeeds ]
 
 
@@ -353,7 +389,33 @@ test_pickle_of_unpickle_is_identity =
 test_unpickle_succeeds :: TestTree
 test_unpickle_succeeds =
   testCase "unpickling succeeds" $ do
-  let path = "test/xml/weatherxml.xml"
-  actual <- unpickleable path pickle_message
-  let expected = True
-  actual @?= expected
+    let path = "test/xml/weatherxml.xml"
+    actual <- unpickleable path pickle_message
+    let expected = True
+    actual @?= expected
+
+
+-- | Make sure everything gets deleted when we delete the top-level
+--   record.
+--
+test_on_delete_cascade :: TestTree
+test_on_delete_cascade =
+  testCase "deleting weather deletes its children" $ do
+    let path = "test/xml/weatherxml.xml"
+    weather <- unsafe_unpickle path pickle_message
+    let a = undefined :: Weather
+    let b = undefined :: WeatherForecast
+    let c = undefined :: WeatherForecastListing
+    actual <- withSqliteConn ":memory:" $ runDbConn $ do
+                runMigration silentMigrationLogger $ do
+                  migrate a
+                  migrate b
+                  migrate c
+                _ <- dbimport weather
+                deleteAll a
+                count_a <- countAll a
+                count_b <- countAll b
+                count_c <- countAll c
+                return $ count_a + count_b + count_c
+    let expected = 0
+    actual @?= expected