src/TSN/XML/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.XML.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   defaultCodegenConfig,
  26   groundhog,
  27   mkPersist )
  28 import Test.Tasty ( TestTree, testGroup )
  29 import Test.Tasty.HUnit ( (@?=), testCase )
  30 import Text.XML.HXT.Core (
  31   PU,
  32   XmlPickler(..),
  33   xp4Tuple,
  34   xp6Tuple,
  35   xpElem,
  36   xpInt,
  37   xpList,
  38   xpPrim,
  39   xpText,
  40   xpWrap )
  41
  42
  43 import TSN.DbImport ( DbImport(..), import_generic )
  44 import Xml ( pickle_unpickle )
  45
  46
  47 data Listing =
  48   Listing {
  49     team :: String,
  50     teamno :: Int,
  51     injuries :: String,
  52     updated :: Bool }
  53   deriving (Eq, Show)
  54
  55 data Message =
  56   Message {
  57     xml_file_id :: Int,
  58     heading :: String,
  59     category :: String,
  60     sport :: String,
  61     listings :: [Listing],
  62     time_stamp :: String }
  63   deriving (Eq, Show)
  64
  65
  66 mkPersist defaultCodegenConfig [groundhog|
  67 - entity: Listing
  68   dbName: injuries
  69 |]
  70
  71
  72 pickle_listing :: PU Listing
  73 pickle_listing =
  74   xpElem "listing" $
  75     xpWrap (from_tuple, to_tuple) $
  76     xp4Tuple (xpElem "team" xpText)
  77              (xpElem "teamno" xpInt)
  78              (xpElem "injuries" xpText)
  79              (xpElem "updated" xpPrim)
  80   where
  81     from_tuple = uncurryN Listing
  82     to_tuple l = (team l, teamno l, injuries l, updated l)
  83
  84 instance XmlPickler Listing where
  85   xpickle = pickle_listing
  86
  87
  88 pickle_message :: PU Message
  89 pickle_message =
  90   xpElem "message" $
  91     xpWrap (from_tuple, to_tuple) $
  92     xp6Tuple (xpElem "XML_File_ID" xpInt)
  93              (xpElem "heading" xpText)
  94              (xpElem "category" xpText)
  95              (xpElem "sport" xpText)
  96              (xpList pickle_listing)
  97              (xpElem "time_stamp" xpText)
  98   where
  99     from_tuple = uncurryN Message
 100     to_tuple m = (xml_file_id m,
 101                   heading m,
 102                   category m,
 103                   sport m,
 104                   listings m,
 105                   time_stamp m)
 106
 107 instance XmlPickler Message where
 108   xpickle = pickle_message
 109
 110
 111
 112 instance DbImport Listing where
 113   dbimport = import_generic listings
 114
 115 -- * Tasty Tests
 116 injuries_tests :: TestTree
 117 injuries_tests =
 118   testGroup
 119     "Injuries tests"
 120     [ test_pickle_of_unpickle_is_identity ]
 121
 122
 123 test_pickle_of_unpickle_is_identity :: TestTree
 124 test_pickle_of_unpickle_is_identity =
 125   testCase "pickle composed with unpickle is the identity" $ do
 126     let path = "test/xml/injuriesxml.xml"
 127     (expected :: [Message], actual) <- pickle_unpickle "message" path
 128     actual @?= expected