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.List.Utils ( join, split )
  18 import Data.Tuple.Curry ( uncurryN )
  19 import Database.Groundhog()
  20 import Database.Groundhog.TH
  21 import Test.Tasty ( TestTree, testGroup )
  22 import Test.Tasty.HUnit ( (@?=), testCase )
  23 import Text.XML.HXT.Core (
  24   PU,
  25   XmlPickler(..),
  26   xp12Tuple,
  27   xpAttr,
  28   xpElem,
  29   xpList,
  30   xpPair,
  31   xpPrim,
  32   xpText,
  33   xpText0,
  34   xpTriple,
  35   xpWrap )
  36
  37
  38 import Xml ( pickle_unpickle )
  39
  40
  41 -- Can't use a newtype with groundhog.
  42 data NewsTeam =
  43   NewsTeam { team_name :: String }
  44   deriving (Eq, Show)
  45
  46 data MsgId =
  47   MsgId {
  48     msg_id   :: Int,
  49     event_id :: String }
  50   deriving (Eq, Show)
  51
  52 data NewsLocation =
  53   NewsLocation {
  54     city :: String,
  55     state :: String,
  56     country :: String }
  57   deriving (Eq, Show)
  58
  59 data Message =
  60   Message {
  61     xml_file_id :: Int,
  62     heading :: String,
  63     mid :: MsgId,
  64     category :: String,
  65     sport :: String,
  66     url :: String,
  67     teams :: [NewsTeam],
  68     locations :: [NewsLocation],
  69     sms :: String,
  70     text :: String,
  71     continue :: String,
  72     time_stamp :: String }
  73   deriving (Eq, Show)
  74
  75
  76 mkPersist defaultCodegenConfig [groundhog|
  77 - entity: NewsTeam
  78   dbName: news_teams
  79
  80 - entity: NewsLocation
  81   dbName: news_locations
  82
  83 - entity: Message
  84   dbName: news
  85   constructors:
  86     - name: Message
  87       fields:
  88         - name: mid
  89           embeddedType:
  90             - {name: msg_id, dbName: msg_id}
  91             - {name: event_id, dbName: event_id}
  92
  93 - embedded: MsgId
  94   fields:
  95     - name: msg_id
  96     - name: event_id
  97 |]
  98
  99
 100 pickle_news_team :: PU NewsTeam
 101 pickle_news_team =
 102   xpElem "team" $
 103     xpWrap (from_string, to_string) xpText
 104   where
 105     to_string :: NewsTeam -> String
 106     to_string = team_name
 107
 108     from_string :: String -> NewsTeam
 109     from_string = NewsTeam
 110
 111 instance XmlPickler NewsTeam where
 112   xpickle = pickle_news_team
 113
 114 pickle_msg_id :: PU MsgId
 115 pickle_msg_id =
 116   xpElem "msg_id" $
 117     xpWrap (from_tuple, to_tuple) $
 118     xpPair xpPrim (xpAttr "EventId" xpText0)
 119   where
 120     from_tuple = uncurryN MsgId
 121     to_tuple m = (msg_id m, event_id m)
 122
 123 instance XmlPickler MsgId where
 124   xpickle = pickle_msg_id
 125
 126 pickle_location :: PU NewsLocation
 127 pickle_location =
 128   xpElem "location" $
 129     xpWrap (from_tuple, to_tuple) $
 130     xpTriple (xpElem "city" xpText)
 131              (xpElem "state" xpText)
 132              (xpElem "country" xpText)
 133   where
 134     from_tuple = uncurryN NewsLocation
 135     to_tuple l = (city l, state l, country l)
 136
 137 instance XmlPickler NewsLocation where
 138   xpickle = pickle_location
 139
 140
 141 pickle_message :: PU Message
 142 pickle_message =
 143   xpElem "message" $
 144     xpWrap (from_tuple, to_tuple) $
 145     xp12Tuple (xpElem "XML_File_ID" xpPrim)
 146               (xpElem "heading" xpText)
 147               pickle_msg_id
 148               (xpElem "category" xpText)
 149               (xpElem "sport" xpText)
 150               (xpElem "url" xpText)
 151               (xpList $ pickle_news_team)
 152               (xpList $ pickle_location)
 153               (xpElem "SMS" xpText)
 154               (xpElem "text" xpText)
 155               pickle_continue
 156               (xpElem "time_stamp" xpText)
 157   where
 158     from_tuple = uncurryN Message
 159     to_tuple m = (xml_file_id m,
 160                   heading m,
 161                   mid m,
 162                   category m,
 163                   sport m,
 164                   url m,
 165                   teams m,
 166                   locations m,
 167                   sms m,
 168                   text m,
 169                   continue m,
 170                   time_stamp m)
 171
 172     pickle_continue :: PU String
 173     pickle_continue =
 174       xpWrap (to_string, from_string) $
 175         xpElem "continue" $
 176           (xpList $ xpElem "P" xpText)
 177       where
 178         from_string :: String -> [String]
 179         from_string = split "\n"
 180
 181         to_string :: [String] -> String
 182         to_string = join "\n"
 183
 184 instance XmlPickler Message where
 185   xpickle = pickle_message
 186
 187
 188
 189 -- * Tasty Tests
 190 news_tests :: TestTree
 191 news_tests =
 192   testGroup
 193     "News tests"
 194     [ test_pickle_of_unpickle_is_identity ]
 195
 196
 197 test_pickle_of_unpickle_is_identity :: TestTree
 198 test_pickle_of_unpickle_is_identity =
 199   testCase "pickle composed with unpickle is the identity" $ do
 200     let path = "test/xml/newsxml.xml"
 201     (expected :: [Message], actual) <- pickle_unpickle "message" path
 202     actual @?= expected