From: Michael Orlitzky Date: Mon, 30 Dec 2013 15:09:48 +0000 (-0500) Subject: Add a TSN.News module and get it to compile. X-Git-Tag: 0.0.1~143 X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=3835f96aea2f383501071106be0a69abd1ef89d1;p=dead%2Fhtsn-import.git Add a TSN.News module and get it to compile. --- 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 \ 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