src/TSN/Injuries.hs

   1 {-# LANGUAGE EmptyDataDecls #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE GADTs #-}
   5 {-# LANGUAGE MultiParamTypeClasses #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE QuasiQuotes #-}
   8 {-# LANGUAGE TemplateHaskell #-}
   9 {-# LANGUAGE TypeFamilies #-}
  10 module TSN.Injuries
  11 where
  12
  13 import Database.Persist.TH (
  14   mkDeleteCascade,
  15   mkMigrate,
  16   mkPersist,
  17   persistLowerCase,
  18   share,
  19   sqlOnlySettings )
  20 import Text.XML.HXT.Core (
  21   PU,
  22   XmlPickler(..),
  23   xp4Tuple,
  24   xp6Tuple,
  25   xpElem,
  26   xpList,
  27   xpPrim,
  28   xpText,
  29   xpWrap )
  30
  31 import Uncurry (uncurry4, uncurry5, uncurry6)
  32
  33 share [mkPersist sqlOnlySettings,
  34        mkDeleteCascade sqlOnlySettings,
  35        mkMigrate "migrate_injuries"] [persistLowerCase|
  36 InjuriesListing
  37   team String
  38   teamno Int
  39   injuries String
  40   updated Bool
  41   deriving Show
  42
  43 InjuriesMessage
  44   xml_file_id Int
  45   heading String
  46   category String
  47   sport String
  48   listings [InjuriesListing]
  49   time_stamp String
  50   deriving Show
  51 |]
  52
  53
  54 pickle_injurieslisting :: PU InjuriesListing
  55 pickle_injurieslisting =
  56   xpElem "listing" $
  57     xpWrap (uncurry4 InjuriesListing,
  58             \l -> (injuriesListingTeam l,
  59                    injuriesListingTeamno l,
  60                    injuriesListingInjuries l,
  61                    injuriesListingUpdated l)) $
  62     xp4Tuple (xpElem "team" xpText)
  63              (xpElem "teamno" xpPrim)
  64              (xpElem "injuries" xpText)
  65              (xpElem "updated" xpPrim)
  66
  67 instance XmlPickler InjuriesListing where
  68   xpickle = pickle_injurieslisting
  69
  70
  71 pickle_injuriesmessage :: PU InjuriesMessage
  72 pickle_injuriesmessage =
  73   xpElem "message" $
  74     xpWrap (uncurry6 InjuriesMessage,
  75             \m -> (injuriesMessageXml_file_id m,
  76                    injuriesMessageHeading m,
  77                    injuriesMessageCategory m,
  78                    injuriesMessageSport m,
  79                    injuriesMessageListings m,
  80                    injuriesMessageTime_stamp m)) $
  81     xp6Tuple (xpElem "XML_File_ID" xpPrim)
  82              (xpElem "heading" xpText)
  83              (xpElem "category" xpText)
  84              (xpElem "sport" xpText)
  85              (xpList pickle_injurieslisting)
  86              (xpElem "time_stamp" xpText)
  87
  88 instance XmlPickler InjuriesMessage where
  89   xpickle = pickle_injuriesmessage