src/TSN/XML/Injuries.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE QuasiQuotes #-}
   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   Message,
  18   injuries_tests )
  19 where
  20
  21 import Data.Data ( Data )
  22 import Data.Typeable ( Typeable )
  23 import Database.Groundhog (
  24   migrate )
  25 import Database.Groundhog.TH (
  26   defaultCodegenConfig,
  27   groundhog,
  28   mkPersist )
  29 import Data.Tuple.Curry ( uncurryN )
  30 import Test.Tasty ( TestTree, testGroup )
  31 import Test.Tasty.HUnit ( (@?=), testCase )
  32 import Text.XML.HXT.Core (
  33   PU,
  34   XmlPickler(..),
  35   xp4Tuple,
  36   xp6Tuple,
  37   xpAttr,
  38   xpElem,
  39   xpInt,
  40   xpList,
  41   xpOption,
  42   xpPair,
  43   xpPrim,
  44   xpText,
  45   xpWrap )
  46
  47
  48 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  49 import TSN.XmlImport ( XmlImport(..) )
  50 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
  51
  52 data InjuriesTeam =
  53   InjuriesTeam {
  54     team_name :: String,
  55     team_league :: Maybe String }
  56   deriving (Data, Eq, Show, Typeable)
  57
  58 data Listing =
  59   Listing {
  60     team :: InjuriesTeam,
  61     teamno :: Maybe Int,
  62     injuries :: String,
  63     updated :: Maybe Bool }
  64   deriving (Eq, Show)
  65
  66 instance FromXml Listing where
  67   type Db Listing = Listing
  68   from_xml = id
  69
  70 instance XmlImport Listing
  71
  72 data Message =
  73   Message {
  74     xml_file_id :: Int,
  75     heading :: String,
  76     category :: String,
  77     sport :: String,
  78     listings :: [Listing],
  79     time_stamp :: String }
  80   deriving (Eq, Show)
  81
  82 instance DbImport Message where
  83   dbimport msg = mapM_ insert_xml (listings msg) >> return ImportSucceeded
  84
  85   dbmigrate _ = run_dbmigrate $ migrate (undefined :: Listing)
  86
  87 mkPersist defaultCodegenConfig [groundhog|
  88 - entity: Listing
  89   dbName: injuries_listings
  90   constructors:
  91     - name: Listing
  92       fields:
  93         - name: team
  94           embeddedType:
  95             - {name: team_name, dbName: team_name}
  96             - {name: team_league, dbName: team_league}
  97 - embedded: InjuriesTeam
  98   fields:
  99     - name: team_name
 100     - name: team_league
 101 |]
 102
 103
 104 pickle_injuries_team :: PU InjuriesTeam
 105 pickle_injuries_team =
 106   xpElem "team" $
 107     xpWrap (from_tuple, to_tuple) $
 108     xpPair xpText (xpOption $ xpAttr "league" xpText)
 109   where
 110     from_tuple = uncurryN InjuriesTeam
 111     to_tuple m = (team_name m, team_league m)
 112
 113 instance XmlPickler InjuriesTeam where
 114   xpickle = pickle_injuries_team
 115
 116 pickle_listing :: PU Listing
 117 pickle_listing =
 118   xpElem "listing" $
 119     xpWrap (from_tuple, to_tuple) $
 120     xp4Tuple pickle_injuries_team
 121              (xpOption $ xpElem "teamno" xpInt)
 122              (xpElem "injuries" xpText)
 123              (xpOption $ xpElem "updated" xpPrim)
 124   where
 125     from_tuple = uncurryN Listing
 126     to_tuple l = (team l, teamno l, injuries l, updated l)
 127
 128 instance XmlPickler Listing where
 129   xpickle = pickle_listing
 130
 131
 132 pickle_message :: PU Message
 133 pickle_message =
 134   xpElem "message" $
 135     xpWrap (from_tuple, to_tuple) $
 136     xp6Tuple (xpElem "XML_File_ID" xpInt)
 137              (xpElem "heading" xpText)
 138              (xpElem "category" xpText)
 139              (xpElem "sport" xpText)
 140              (xpList pickle_listing)
 141              (xpElem "time_stamp" xpText)
 142   where
 143     from_tuple = uncurryN Message
 144     to_tuple m = (xml_file_id m,
 145                   heading m,
 146                   category m,
 147                   sport m,
 148                   listings m,
 149                   time_stamp m)
 150
 151 instance XmlPickler Message where
 152   xpickle = pickle_message
 153
 154
 155
 156 -- * Tasty Tests
 157 injuries_tests :: TestTree
 158 injuries_tests =
 159   testGroup
 160     "Injuries tests"
 161     [ test_pickle_of_unpickle_is_identity,
 162       test_unpickle_succeeds ]
 163
 164
 165 -- | Warning, succeess of this test does not mean that unpickling
 166 --   succeeded.
 167 test_pickle_of_unpickle_is_identity :: TestTree
 168 test_pickle_of_unpickle_is_identity =
 169   testCase "pickle composed with unpickle is the identity" $ do
 170     let path = "test/xml/injuriesxml.xml"
 171     (expected, actual) <- pickle_unpickle pickle_message path
 172     actual @?= expected
 173
 174
 175 test_unpickle_succeeds :: TestTree
 176 test_unpickle_succeeds =
 177   testCase "unpickling succeeds" $ do
 178   let path = "test/xml/injuriesxml.xml"
 179   actual <- unpickleable path pickle_message
 180   let expected = True
 181   actual @?= expected