From 3835f96aea2f383501071106be0a69abd1ef89d1 Mon Sep 17 00:00:00 2001
From: Michael Orlitzky <michael@orlitzky.com>
Date: Mon, 30 Dec 2013 10:09:48 -0500
Subject: [PATCH] Add a TSN.News module and get it to compile.

---
 src/Main.hs     |   6 ++
 src/TSN/News.hs | 152 ++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 158 insertions(+)
 create mode 100644 src/TSN/News.hs

diff --git a/src/Main.hs b/src/Main.hs
index b81b6f0..9730f5e 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -54,6 +54,7 @@ import qualified TSN.InjuriesDetail as InjuriesDetail (
   Listing ( player_listings ),
   Message ( listings ),
   PlayerListing )
+import qualified TSN.News as News
 import Xml ( parse_opts )
 
 
@@ -91,6 +92,10 @@ import_generic dummy g cfg xml
 
 
 
+-- | Import TSN.News from an 'XmlTree'.
+import_news :: Configuration -> XmlTree -> IO (Maybe Int)
+import_news = undefined
+
 -- | Import TSN.Injuries from an 'XmlTree'.
 import_injuries :: Configuration -> XmlTree -> IO (Maybe Int)
 import_injuries =
@@ -154,6 +159,7 @@ import_file cfg path = do
     import_with_dtd (dtd,xml)
       | dtd == "injuriesxml.dtd" = import_injuries cfg xml
       | dtd == "Injuries_Detail_XML.dtd" = import_injuries_detail cfg xml
+      | dtd == "newsxml.dtd" = import_news cfg xml
       | otherwise = do
           report_info $ "Unrecognized DTD in " ++ path ++ ": " ++ dtd ++ "."
           return Nothing
diff --git a/src/TSN/News.hs b/src/TSN/News.hs
new file mode 100644
index 0000000..4e24c3a
--- /dev/null
+++ b/src/TSN/News.hs
@@ -0,0 +1,152 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | Parse TSN XML for the DTD "newsxml.dtd". Each document contains a
+--   root element \<message\> that contains an entire news item.
+--
+module TSN.News (
+  Message,
+  news_tests )
+where
+
+import Data.Tuple.Curry ( uncurryN )
+import Database.Groundhog()
+import Database.Groundhog.TH
+import Test.Tasty ( TestTree, testGroup )
+import Test.Tasty.HUnit ( (@?=), testCase )
+import Text.XML.HXT.Core (
+  PU,
+  XmlPickler(..),
+  xp12Tuple,
+  xpAttr,
+  xpElem,
+  xpList,
+  xpPair,
+  xpPrim,
+  xpText,
+  xpText0,
+  xpTriple,
+  xpWrap )
+
+
+import Xml ( pickle_unpickle )
+
+
+data MsgId =
+  MsgId {
+    msg_id_text   :: Int,
+    event_id :: String }
+  deriving (Eq, Show)
+
+data Location =
+  Location {
+    city :: String,
+    state :: String,
+    country :: String }
+  deriving (Eq, Show)
+
+data Message =
+  Message {
+    xml_file_id :: Int,
+    msg_id :: MsgId,
+    heading :: String,
+    category :: String,
+    sport :: String,
+    url :: String,
+    teams :: [String],
+    location :: Location,
+    sms :: String,
+    text :: String,
+    continue :: String,
+    time_stamp :: String }
+  deriving (Eq, Show)
+
+
+-- mkPersist defaultCodegenConfig [groundhog|
+-- - entity: Message
+--   dbName: injuries
+-- |]
+
+
+pickle_msg_id :: PU MsgId
+pickle_msg_id =
+  xpElem "msg_id" $
+    xpWrap (from_tuple, to_tuple) $
+    xpPair xpPrim (xpAttr "EventId" xpText0)
+  where
+    from_tuple = uncurryN MsgId
+    to_tuple m = (msg_id_text m, event_id m)
+
+instance XmlPickler MsgId where
+  xpickle = pickle_msg_id
+
+pickle_location :: PU Location
+pickle_location =
+  xpElem "listing" $
+    xpWrap (from_tuple, to_tuple) $
+    xpTriple (xpElem "city" xpText)
+             (xpElem "state" xpPrim)
+             (xpElem "location" xpText)
+  where
+    from_tuple = uncurryN Location
+    to_tuple l = (city l, state l, country l)
+
+instance XmlPickler Location where
+  xpickle = pickle_location
+
+
+pickle_message :: PU Message
+pickle_message =
+  xpElem "message" $
+    xpWrap (from_tuple, to_tuple) $
+    xp12Tuple (xpElem "XML_File_ID" xpPrim)
+              pickle_msg_id
+              (xpElem "heading" xpText)
+              (xpElem "category" xpText)
+              (xpElem "sport" xpText)
+              (xpElem "url" xpText)
+              (xpList $ xpElem "team" xpText)
+              (pickle_location)
+              (xpElem "sms" xpText)
+              (xpElem "text" xpText)
+              (xpElem "continue" xpText)
+              (xpElem "time_stamp" xpText)
+  where
+    from_tuple = uncurryN Message
+    to_tuple m = (xml_file_id m,
+                  msg_id m,
+                  heading m,
+                  category m,
+                  sport m,
+                  url m,
+                  teams m,
+                  location m,
+                  sms m,
+                  text m,
+                  continue m,
+                  time_stamp m)
+
+instance XmlPickler Message where
+  xpickle = pickle_message
+
+
+
+-- * Tasty Tests
+news_tests :: TestTree
+news_tests =
+  testGroup
+    "News tests"
+    [ test_pickle_of_unpickle_is_identity ]
+
+
+test_pickle_of_unpickle_is_identity :: TestTree
+test_pickle_of_unpickle_is_identity =
+  testCase "pickle composed with unpickle is the identity" $ do
+    let path = "test/xml/newsxml.xml"
+    (expected :: [Message], actual) <- pickle_unpickle "message" path
+    actual @?= expected
-- 
2.43.2