src/TSN/Injuries.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE QuasiQuotes #-}
   4 {-# LANGUAGE StandaloneDeriving #-}
   5 {-# LANGUAGE TemplateHaskell #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7
   8 -- | Parse TSN XML for the DTD "injuriesxml.dtd". Each document
   9 --   contains a root element \<message\> that in turn contains zero or
  10 --   more \<listing\>s.
  11 --
  12 --   The listings will be mapped to a database table called "injuries"
  13 --   automatically. The root message is not retained.
  14 --
  15 module TSN.Injuries (
  16   Listing,
  17   Message( listings ) )
  18 where
  19
  20 import Data.Tuple.Curry ( uncurryN )
  21 import Database.Groundhog()
  22 import Database.Groundhog.TH
  23 import Text.XML.HXT.Core (
  24   PU,
  25   XmlPickler(..),
  26   xp4Tuple,
  27   xp6Tuple,
  28   xpElem,
  29   xpList,
  30   xpPrim,
  31   xpText,
  32   xpWrap )
  33
  34
  35 data Listing =
  36   Listing {
  37     team :: String,
  38     teamno :: Int,
  39     injuries :: String,
  40     updated :: Bool }
  41   deriving (Show)
  42
  43 data Message =
  44   Message {
  45     xml_file_id :: Int,
  46     heading :: String,
  47     category :: String,
  48     sport :: String,
  49     listings :: [Listing],
  50     time_stamp :: String }
  51   deriving (Show)
  52
  53
  54 mkPersist defaultCodegenConfig [groundhog|
  55 - entity: Listing
  56   dbName: injuries
  57 |]
  58
  59
  60 pickle_listing :: PU Listing
  61 pickle_listing =
  62   xpElem "listing" $
  63     xpWrap (from_tuple, to_tuple) $
  64     xp4Tuple (xpElem "team" xpText)
  65              (xpElem "teamno" xpPrim)
  66              (xpElem "injuries" xpText)
  67              (xpElem "updated" xpPrim)
  68   where
  69     from_tuple = uncurryN Listing
  70     to_tuple l = (team l, teamno l, injuries l, updated l)
  71
  72 instance XmlPickler Listing where
  73   xpickle = pickle_listing
  74
  75
  76 pickle_message :: PU Message
  77 pickle_message =
  78   xpElem "message" $
  79     xpWrap (from_tuple, to_tuple) $
  80     xp6Tuple (xpElem "XML_File_ID" xpPrim)
  81              (xpElem "heading" xpText)
  82              (xpElem "category" xpText)
  83              (xpElem "sport" xpText)
  84              (xpList pickle_listing)
  85              (xpElem "time_stamp" xpText)
  86   where
  87     from_tuple = uncurryN Message
  88     to_tuple m = (xml_file_id m,
  89                   heading m,
  90                   category m,
  91                   sport m,
  92                   listings m,
  93                   time_stamp m)
  94
  95 instance XmlPickler Message where
  96   xpickle = pickle_message