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