src/TSN/Injuries.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 "injuriesxml.dtd". Each document
  10 --   contains a root element \<message\> that in turn contains zero or
  11 --   more \<listing\>s.
  12 --
  13 --   The listings will be mapped to a database table called "injuries"
  14 --   automatically. The root message is not retained.
  15 --
  16 module TSN.Injuries (
  17   Listing,
  18   Message( listings ),
  19   injuries_tests )
  20 where
  21
  22 import Data.Tuple.Curry ( uncurryN )
  23 import Database.Groundhog()
  24 import Database.Groundhog.TH
  25 import Test.Tasty ( TestTree, testGroup )
  26 import Test.Tasty.HUnit ( (@?=), testCase )
  27 import Text.XML.HXT.Core (
  28   PU,
  29   XmlPickler(..),
  30   xp4Tuple,
  31   xp6Tuple,
  32   xpElem,
  33   xpList,
  34   xpPrim,
  35   xpText,
  36   xpWrap )
  37
  38
  39 import Xml ( pickle_unpickle )
  40
  41
  42 data Listing =
  43   Listing {
  44     team :: String,
  45     teamno :: Int,
  46     injuries :: String,
  47     updated :: Bool }
  48   deriving (Eq, Show)
  49
  50 data Message =
  51   Message {
  52     xml_file_id :: Int,
  53     heading :: String,
  54     category :: String,
  55     sport :: String,
  56     listings :: [Listing],
  57     time_stamp :: String }
  58   deriving (Eq, Show)
  59
  60
  61 mkPersist defaultCodegenConfig [groundhog|
  62 - entity: Listing
  63   dbName: injuries
  64 |]
  65
  66
  67 pickle_listing :: PU Listing
  68 pickle_listing =
  69   xpElem "listing" $
  70     xpWrap (from_tuple, to_tuple) $
  71     xp4Tuple (xpElem "team" xpText)
  72              (xpElem "teamno" xpPrim)
  73              (xpElem "injuries" xpText)
  74              (xpElem "updated" xpPrim)
  75   where
  76     from_tuple = uncurryN Listing
  77     to_tuple l = (team l, teamno l, injuries l, updated l)
  78
  79 instance XmlPickler Listing where
  80   xpickle = pickle_listing
  81
  82
  83 pickle_message :: PU Message
  84 pickle_message =
  85   xpElem "message" $
  86     xpWrap (from_tuple, to_tuple) $
  87     xp6Tuple (xpElem "XML_File_ID" xpPrim)
  88              (xpElem "heading" xpText)
  89              (xpElem "category" xpText)
  90              (xpElem "sport" xpText)
  91              (xpList pickle_listing)
  92              (xpElem "time_stamp" xpText)
  93   where
  94     from_tuple = uncurryN Message
  95     to_tuple m = (xml_file_id m,
  96                   heading m,
  97                   category m,
  98                   sport m,
  99                   listings m,
 100                   time_stamp m)
 101
 102 instance XmlPickler Message where
 103   xpickle = pickle_message
 104
 105
 106
 107 -- * Tasty Tests
 108 injuries_tests :: TestTree
 109 injuries_tests =
 110   testGroup
 111     "Injuries tests"
 112     [ test_pickle_of_unpickle_is_identity ]
 113
 114
 115 test_pickle_of_unpickle_is_identity :: TestTree
 116 test_pickle_of_unpickle_is_identity =
 117   testCase "pickle composed with unpickle is the identity" $ do
 118     let path = "test/xml/injuriesxml.xml"
 119     (expected :: [Message], actual) <- pickle_unpickle "message" path
 120     actual @?= expected