X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FInjuries.hs;h=3877c12efc551a5e6c55ee3bed5d2354e5be7b6e;hb=9d278c8b8eeff1a1317f2c3b0f7fdf5fb759ffb3;hp=7425ab5241025a6273ae9388710cf193ea00ed3b;hpb=3f7a07312dfbdae0d71b2c0d181c93df9ffe53b4;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/Injuries.hs b/src/TSN/Injuries.hs
index 7425ab5..3877c12 100644
--- a/src/TSN/Injuries.hs
+++ b/src/TSN/Injuries.hs
@@ -1,76 +1,96 @@
-{-# LANGUAGE EmptyDataDecls #-}
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-module TSN.Injuries
+
+-- | Parse TSN XML for the DTD "injuriesxml.dtd". Each document
+--   contains a root element \<message\> that in turn contains zero or
+--   more \<listing\>s.
+--
+--   The listings will be mapped to a database table called "injuries"
+--   automatically. The root message is not retained.
+--
+module TSN.Injuries (
+  Listing,
+  Message( listings ) )
 where
 
-import Generics.Regular
-import Database.Persist.TH
-import Text.XML.HXT.Core
+import Data.Tuple.Curry ( uncurryN )
+import Database.Groundhog()
+import Database.Groundhog.TH
+import Text.XML.HXT.Core (
+  PU,
+  XmlPickler(..),
+  xp4Tuple,
+  xp6Tuple,
+  xpElem,
+  xpList,
+  xpPrim,
+  xpText,
+  xpWrap )
+
+
+data Listing =
+  Listing {
+    team :: String,
+    teamno :: Int,
+    injuries :: String,
+    updated :: Bool }
+  deriving (Show)
+
+data Message =
+  Message {
+    xml_file_id :: Int,
+    heading :: String,
+    category :: String,
+    sport :: String,
+    listings :: [Listing],
+    time_stamp :: String }
+  deriving (Show)
 
-share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
-Listing
-  team String
-  teamno Int
-  injuries String
-  updated Bool
-  deriving Show
 
-Message
-  xml_file_id Int
-  heading String
-  category String
-  sport String
-  listings [Listing]
-  time_stamp String
-  deriving Show
+mkPersist defaultCodegenConfig [groundhog|
+- entity: Listing
+  dbName: injuries
 |]
 
+
 pickle_listing :: PU Listing
 pickle_listing =
   xpElem "listing" $
-    xpWrap (\(w,x,y,z) -> Listing w x y z,
-            \l -> (listingTeam l,
-                   listingTeamno l,
-                   listingInjuries l,
-                   listingUpdated l)) $
+    xpWrap (from_tuple, to_tuple) $
     xp4Tuple (xpElem "team" xpText)
              (xpElem "teamno" xpPrim)
              (xpElem "injuries" xpText)
              (xpElem "updated" xpPrim)
+  where
+    from_tuple = uncurryN Listing
+    to_tuple l = (team l, teamno l, injuries l, updated l)
 
 instance XmlPickler Listing where
   xpickle = pickle_listing
 
-$(deriveAll ''Listing "PFListing")
-type instance PF Listing = PFListing
-
 
 pickle_message :: PU Message
 pickle_message =
   xpElem "message" $
-    xpWrap (\(u,v,w,x,y,z) -> Message u v w x y z,
-            \m -> (messageXml_file_id m,
-                   messageHeading m,
-                   messageCategory m,
-                   messageSport m,
-                   messageListings m,
-                   messageTime_stamp m)) $
+    xpWrap (from_tuple, to_tuple) $
     xp6Tuple (xpElem "XML_File_ID" xpPrim)
              (xpElem "heading" xpText)
              (xpElem "category" xpText)
              (xpElem "sport" xpText)
              (xpList pickle_listing)
              (xpElem "time_stamp" xpText)
+  where
+    from_tuple = uncurryN Message
+    to_tuple m = (xml_file_id m,
+                  heading m,
+                  category m,
+                  sport m,
+                  listings m,
+                  time_stamp m)
 
 instance XmlPickler Message where
   xpickle = pickle_message
-
-$(deriveAll ''Message "PFMessage")
-type instance PF Message = PFMessage