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   pickle_message,
  18   -- * Tests
  19   injuries_tests,
  20   -- * WARNING: these are private but exported to silence warnings
  21   ListingConstructor(..) )
  22 where
  23
  24 import Data.Data ( Data )
  25 import Data.Typeable ( Typeable )
  26 import Database.Groundhog (
  27   migrate )
  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   xp4Tuple,
  38   xp6Tuple,
  39   xpAttr,
  40   xpElem,
  41   xpInt,
  42   xpList,
  43   xpOption,
  44   xpPair,
  45   xpPrim,
  46   xpText,
  47   xpWrap )
  48
  49
  50 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  51 import TSN.XmlImport ( XmlImport(..) )
  52 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
  53
  54 data InjuriesTeam =
  55   InjuriesTeam {
  56     team_name :: String,
  57     team_league :: Maybe String }
  58   deriving (Data, Eq, Show, Typeable)
  59
  60 data Listing =
  61   Listing {
  62     team :: InjuriesTeam,
  63     teamno :: Maybe Int,
  64     injuries :: String,
  65     updated :: Maybe Bool }
  66   deriving (Eq, Show)
  67
  68 instance FromXml Listing where
  69   type Db Listing = Listing
  70   from_xml = id
  71
  72 instance XmlImport Listing
  73
  74 data Message =
  75   Message {
  76     xml_file_id :: Int,
  77     heading :: String,
  78     category :: String,
  79     sport :: String,
  80     listings :: [Listing],
  81     time_stamp :: String }
  82   deriving (Eq, Show)
  83
  84 instance DbImport Message where
  85   dbimport msg = mapM_ insert_xml (listings msg) >> return ImportSucceeded
  86
  87   dbmigrate _ = run_dbmigrate $ migrate (undefined :: Listing)
  88
  89 mkPersist defaultCodegenConfig [groundhog|
  90 - entity: Listing
  91   dbName: injuries_listings
  92   constructors:
  93     - name: Listing
  94       fields:
  95         - name: team
  96           embeddedType:
  97             - {name: team_name, dbName: team_name}
  98             - {name: team_league, dbName: team_league}
  99 - embedded: InjuriesTeam
 100   fields:
 101     - name: team_name
 102     - name: team_league
 103 |]
 104
 105
 106 pickle_injuries_team :: PU InjuriesTeam
 107 pickle_injuries_team =
 108   xpElem "team" $
 109     xpWrap (from_tuple, to_tuple) $
 110     xpPair xpText (xpOption $ xpAttr "league" xpText)
 111   where
 112     from_tuple = uncurryN InjuriesTeam
 113     to_tuple m = (team_name m, team_league m)
 114
 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
 129 pickle_message :: PU Message
 130 pickle_message =
 131   xpElem "message" $
 132     xpWrap (from_tuple, to_tuple) $
 133     xp6Tuple (xpElem "XML_File_ID" xpInt)
 134              (xpElem "heading" xpText)
 135              (xpElem "category" xpText)
 136              (xpElem "sport" xpText)
 137              (xpList pickle_listing)
 138              (xpElem "time_stamp" xpText)
 139   where
 140     from_tuple = uncurryN Message
 141     to_tuple m = (xml_file_id m,
 142                   heading m,
 143                   category m,
 144                   sport m,
 145                   listings m,
 146                   time_stamp m)
 147
 148
 149 --
 150 -- Tasty Tests
 151 --
 152
 153 -- | A list of all tests for this module.
 154 --
 155 injuries_tests :: TestTree
 156 injuries_tests =
 157   testGroup
 158     "Injuries tests"
 159     [ test_pickle_of_unpickle_is_identity,
 160       test_unpickle_succeeds ]
 161
 162
 163 -- | If we unpickle something and then pickle it, we should wind up
 164 --   with the same thing we started with. WARNING: succeess of this
 165 --   test does not mean that unpickling succeeded.
 166 --
 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 -- | Make sure we can actually unpickle these things.
 176 --
 177 test_unpickle_succeeds :: TestTree
 178 test_unpickle_succeeds =
 179   testCase "unpickling succeeds" $ do
 180   let path = "test/xml/injuriesxml.xml"
 181   actual <- unpickleable path pickle_message
 182   let expected = True
 183   actual @?= expected