Get pickling (but not insertion) working for TSN.News.

diff --git a/htsn-import.cabal b/htsn-import.cabal
index cbec4e6646dd62ed6afe411b31870bd37dee022a..362beac36ef73d053f313ad5737f8a22bb2f8509 100644 (file)
--- a/htsn-import.cabal
+++ b/htsn-import.cabal
@@ -26,6 +26,7 @@ executable htsn-import
     groundhog-postgresql        == 0.4.*,
     groundhog-sqlite            == 0.4.*,
     groundhog-th                == 0.4.*,
+    MissingH                    == 1.2.*,
     old-locale                  == 1.0.*,
     tasty                       == 0.7.*,
     tasty-hunit                 == 0.4.*,
@@ -79,6 +80,7 @@ test-suite testsuite
     groundhog-postgresql        == 0.4.*,
     groundhog-sqlite            == 0.4.*,
     groundhog-th                == 0.4.*,
+    MissingH                    == 1.2.*,
     old-locale                  == 1.0.*,
     tasty                       == 0.7.*,
     tasty-hunit                 == 0.4.*,

diff --git a/src/Main.hs b/src/Main.hs
index 9730f5e33fd9caf28fd69f2013a32cc7e74f3a1c..448577773dd8af187611d521f1db444916f532f3 100644 (file)
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -54,7 +54,7 @@ import qualified TSN.InjuriesDetail as InjuriesDetail (
   Listing ( player_listings ),
   Message ( listings ),
   PlayerListing )
-import qualified TSN.News as News
+import qualified TSN.News as News ( Message )
 import Xml ( parse_opts )
 
 
@@ -94,7 +94,10 @@ import_generic dummy g cfg xml
 
 -- | Import TSN.News from an 'XmlTree'.
 import_news :: Configuration -> XmlTree -> IO (Maybe Int)
-import_news = undefined
+import_news =
+  import_generic
+    (undefined :: News.Message)
+    id
 
 -- | Import TSN.Injuries from an 'XmlTree'.
 import_injuries :: Configuration -> XmlTree -> IO (Maybe Int)

diff --git a/src/TSN/News.hs b/src/TSN/News.hs
index 4e24c3ae0e89fa575dbc2d54e519645306d2e11c..74b48463edb071ceac391355247a7cf6556ee6bd 100644 (file)
--- a/src/TSN/News.hs
+++ b/src/TSN/News.hs
@@ -14,6 +14,7 @@ module TSN.News (
   news_tests )
 where
 
+import Data.List.Utils ( join, split )
 import Data.Tuple.Curry ( uncurryN )
 import Database.Groundhog()
 import Database.Groundhog.TH
@@ -37,14 +38,19 @@ import Text.XML.HXT.Core (
 import Xml ( pickle_unpickle )
 
 
+-- Can't use a newtype with groundhog.
+data NewsTeam =
+  NewsTeam { team_name :: String }
+  deriving (Eq, Show)
+
 data MsgId =
   MsgId {
-    msg_id_text   :: Int,
+    msg_id   :: Int,
     event_id :: String }
   deriving (Eq, Show)
 
-data Location =
-  Location {
+data NewsLocation =
+  NewsLocation {
     city :: String,
     state :: String,
     country :: String }
@@ -53,13 +59,13 @@ data Location =
 data Message =
   Message {
     xml_file_id :: Int,
-    msg_id :: MsgId,
     heading :: String,
+    mid :: MsgId,
     category :: String,
     sport :: String,
     url :: String,
-    teams :: [String],
-    location :: Location,
+    teams :: [NewsTeam],
+    locations :: [NewsLocation],
     sms :: String,
     text :: String,
     continue :: String,
@@ -67,11 +73,43 @@ data Message =
   deriving (Eq, Show)
 
 
--- mkPersist defaultCodegenConfig [groundhog|
--- - entity: Message
---   dbName: injuries
--- |]
+mkPersist defaultCodegenConfig [groundhog|
+- entity: NewsTeam
+  dbName: news_teams
+
+- entity: NewsLocation
+  dbName: news_locations
+
+- entity: Message
+  dbName: news
+  constructors:
+    - name: Message
+      fields:
+        - name: mid
+          embeddedType:
+            - {name: msg_id, dbName: msg_id}
+            - {name: event_id, dbName: event_id}
+
+- embedded: MsgId
+  fields:
+    - name: msg_id
+    - name: event_id
+|]
+
 
+pickle_news_team :: PU NewsTeam
+pickle_news_team =
+  xpElem "team" $
+    xpWrap (from_string, to_string) xpText
+  where
+    to_string :: NewsTeam -> String
+    to_string = team_name
+
+    from_string :: String -> NewsTeam
+    from_string = NewsTeam
+
+instance XmlPickler NewsTeam where
+  xpickle = pickle_news_team
 
 pickle_msg_id :: PU MsgId
 pickle_msg_id =
@@ -80,23 +118,23 @@ pickle_msg_id =
     xpPair xpPrim (xpAttr "EventId" xpText0)
   where
     from_tuple = uncurryN MsgId
-    to_tuple m = (msg_id_text m, event_id m)
+    to_tuple m = (msg_id m, event_id m)
 
 instance XmlPickler MsgId where
   xpickle = pickle_msg_id
 
-pickle_location :: PU Location
+pickle_location :: PU NewsLocation
 pickle_location =
-  xpElem "listing" $
+  xpElem "location" $
     xpWrap (from_tuple, to_tuple) $
     xpTriple (xpElem "city" xpText)
-             (xpElem "state" xpPrim)
-             (xpElem "location" xpText)
+             (xpElem "state" xpText)
+             (xpElem "country" xpText)
   where
-    from_tuple = uncurryN Location
+    from_tuple = uncurryN NewsLocation
     to_tuple l = (city l, state l, country l)
 
-instance XmlPickler Location where
+instance XmlPickler NewsLocation where
   xpickle = pickle_location
 
 
@@ -105,32 +143,44 @@ pickle_message =
   xpElem "message" $
     xpWrap (from_tuple, to_tuple) $
     xp12Tuple (xpElem "XML_File_ID" xpPrim)
-              pickle_msg_id
               (xpElem "heading" xpText)
+              pickle_msg_id
               (xpElem "category" xpText)
               (xpElem "sport" xpText)
               (xpElem "url" xpText)
-              (xpList $ xpElem "team" xpText)
-              (pickle_location)
-              (xpElem "sms" xpText)
+              (xpList $ pickle_news_team)
+              (xpList $ pickle_location)
+              (xpElem "SMS" xpText)
               (xpElem "text" xpText)
-              (xpElem "continue" xpText)
+              pickle_continue
               (xpElem "time_stamp" xpText)
   where
     from_tuple = uncurryN Message
     to_tuple m = (xml_file_id m,
-                  msg_id m,
                   heading m,
+                  mid m,
                   category m,
                   sport m,
                   url m,
                   teams m,
-                  location m,
+                  locations m,
                   sms m,
                   text m,
                   continue m,
                   time_stamp m)
 
+    pickle_continue :: PU String
+    pickle_continue =
+      xpWrap (to_string, from_string) $
+        xpElem "continue" $
+          (xpList $ xpElem "P" xpText)
+      where
+        from_string :: String -> [String]
+        from_string = split "\n"
+
+        to_string :: [String] -> String
+        to_string = join "\n"
+
 instance XmlPickler Message where
   xpickle = pickle_message
 

diff --git a/test/TestSuite.hs b/test/TestSuite.hs
index 17d9a24985fc43add0f512c7156361bf375b9132..f5f1b4f9d4bfd23f6fed43c2f4e09870b4c7c894 100644 (file)
--- a/test/TestSuite.hs
+++ b/test/TestSuite.hs
@@ -2,11 +2,14 @@ import Test.Tasty ( TestTree, defaultMain, testGroup )
 
 import TSN.Injuries ( injuries_tests )
 import TSN.InjuriesDetail ( injuries_detail_tests )
+import TSN.News ( news_tests )
 
 tests :: TestTree
 tests = testGroup
           "All tests"
-          [ injuries_tests, injuries_detail_tests ]
+          [ injuries_tests,
+            injuries_detail_tests,
+            news_tests ]
 
 main :: IO ()
 main = defaultMain tests