src/TSN/News.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE QuasiQuotes #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5 {-# LANGUAGE StandaloneDeriving #-}
   6 {-# LANGUAGE TemplateHaskell #-}
   7 {-# LANGUAGE TypeFamilies #-}
   8
   9 -- | Parse TSN XML for the DTD "newsxml.dtd". Each document contains a
  10 --   root element \<message\> that contains an entire news item.
  11 --
  12 module TSN.News (
  13   Message,
  14   news_tests )
  15 where
  16
  17 import Data.Tuple.Curry ( uncurryN )
  18 import Database.Groundhog()
  19 import Database.Groundhog.TH
  20 import Test.Tasty ( TestTree, testGroup )
  21 import Test.Tasty.HUnit ( (@?=), testCase )
  22 import Text.XML.HXT.Core (
  23   PU,
  24   XmlPickler(..),
  25   xp12Tuple,
  26   xpAttr,
  27   xpElem,
  28   xpList,
  29   xpPair,
  30   xpPrim,
  31   xpText,
  32   xpText0,
  33   xpTriple,
  34   xpWrap )
  35
  36
  37 import Xml ( pickle_unpickle )
  38
  39
  40 data MsgId =
  41   MsgId {
  42     msg_id_text   :: Int,
  43     event_id :: String }
  44   deriving (Eq, Show)
  45
  46 data Location =
  47   Location {
  48     city :: String,
  49     state :: String,
  50     country :: String }
  51   deriving (Eq, Show)
  52
  53 data Message =
  54   Message {
  55     xml_file_id :: Int,
  56     msg_id :: MsgId,
  57     heading :: String,
  58     category :: String,
  59     sport :: String,
  60     url :: String,
  61     teams :: [String],
  62     location :: Location,
  63     sms :: String,
  64     text :: String,
  65     continue :: String,
  66     time_stamp :: String }
  67   deriving (Eq, Show)
  68
  69
  70 -- mkPersist defaultCodegenConfig [groundhog|
  71 -- - entity: Message
  72 --   dbName: injuries
  73 -- |]
  74
  75
  76 pickle_msg_id :: PU MsgId
  77 pickle_msg_id =
  78   xpElem "msg_id" $
  79     xpWrap (from_tuple, to_tuple) $
  80     xpPair xpPrim (xpAttr "EventId" xpText0)
  81   where
  82     from_tuple = uncurryN MsgId
  83     to_tuple m = (msg_id_text m, event_id m)
  84
  85 instance XmlPickler MsgId where
  86   xpickle = pickle_msg_id
  87
  88 pickle_location :: PU Location
  89 pickle_location =
  90   xpElem "listing" $
  91     xpWrap (from_tuple, to_tuple) $
  92     xpTriple (xpElem "city" xpText)
  93              (xpElem "state" xpPrim)
  94              (xpElem "location" xpText)
  95   where
  96     from_tuple = uncurryN Location
  97     to_tuple l = (city l, state l, country l)
  98
  99 instance XmlPickler Location where
 100   xpickle = pickle_location
 101
 102
 103 pickle_message :: PU Message
 104 pickle_message =
 105   xpElem "message" $
 106     xpWrap (from_tuple, to_tuple) $
 107     xp12Tuple (xpElem "XML_File_ID" xpPrim)
 108               pickle_msg_id
 109               (xpElem "heading" xpText)
 110               (xpElem "category" xpText)
 111               (xpElem "sport" xpText)
 112               (xpElem "url" xpText)
 113               (xpList $ xpElem "team" xpText)
 114               (pickle_location)
 115               (xpElem "sms" xpText)
 116               (xpElem "text" xpText)
 117               (xpElem "continue" xpText)
 118               (xpElem "time_stamp" xpText)
 119   where
 120     from_tuple = uncurryN Message
 121     to_tuple m = (xml_file_id m,
 122                   msg_id m,
 123                   heading m,
 124                   category m,
 125                   sport m,
 126                   url m,
 127                   teams m,
 128                   location m,
 129                   sms m,
 130                   text m,
 131                   continue m,
 132                   time_stamp m)
 133
 134 instance XmlPickler Message where
 135   xpickle = pickle_message
 136
 137
 138
 139 -- * Tasty Tests
 140 news_tests :: TestTree
 141 news_tests =
 142   testGroup
 143     "News tests"
 144     [ test_pickle_of_unpickle_is_identity ]
 145
 146
 147 test_pickle_of_unpickle_is_identity :: TestTree
 148 test_pickle_of_unpickle_is_identity =
 149   testCase "pickle composed with unpickle is the identity" $ do
 150     let path = "test/xml/newsxml.xml"
 151     (expected :: [Message], actual) <- pickle_unpickle "message" path
 152     actual @?= expected