src/TSN/XML/Injuries.hs

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