X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FInjuriesDetail.hs;h=38e0268a4e1d518cf6d00c1d0fed2d8f8c8661d0;hb=d476419274cdf2997d768444cecc47922a902fdf;hp=e26cd1ce042f742b2de3f24c4de721688b95aa5f;hpb=c792c3bb79e83b5bb8d65984de51f2416b7a2d8e;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/XML/InjuriesDetail.hs b/src/TSN/XML/InjuriesDetail.hs
index e26cd1c..38e0268 100644
--- a/src/TSN/XML/InjuriesDetail.hs
+++ b/src/TSN/XML/InjuriesDetail.hs
@@ -1,7 +1,6 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -18,8 +17,11 @@
 --   are not retained.
 --
 module TSN.XML.InjuriesDetail (
-  Message,
-  injuries_detail_tests )
+  pickle_message,
+  -- * Tests
+  injuries_detail_tests,
+  -- * WARNING: these are private but exported to silence warnings
+  PlayerListingConstructor(..) )
 where
 
 import Data.Time ( UTCTime )
@@ -34,16 +36,15 @@ import Test.Tasty ( TestTree, testGroup )
 import Test.Tasty.HUnit ( (@?=), testCase )
 import Text.XML.HXT.Core (
   PU,
-  XmlPickler(..),
   xpTriple,
   xp6Tuple,
   xp10Tuple,
   xpElem,
   xpInt,
   xpList,
+  xpOption,
   xpPrim,
   xpText,
-  xpText0,
   xpWrap )
 
 import TSN.Picklers( xp_date, xp_team_id )
@@ -54,14 +55,15 @@ import Xml ( FromXml(..), pickle_unpickle, unpickleable )
 
 data PlayerListing =
   PlayerListing {
-    team_id   :: Int,
+    team_id   :: String, -- ^ TeamIDs are (apparently) three characters long
+                         --   and not necessarily numeric.
     player_id :: Int,
     date      :: UTCTime,
     pos       :: String,
     name      :: String,
     injury    :: String,
     status    :: String,
-    fantasy   :: String, -- ^ Nobody knows what this is.
+    fantasy   :: Maybe String, -- ^ Nobody knows what this is.
     injured     :: Bool,
     injury_type :: String -- ^ "type" is a reserved keyword so we can't use it
     }
@@ -75,7 +77,9 @@ instance XmlImport PlayerListing
 
 data Listing =
   Listing {
-    listing_team_id :: Int -- ^ Avoid conflict with PlayerListing's team_id
+    listing_team_id :: String -- ^ Avoid conflict with PlayerListing's team_id.
+                              --   TeamIDs are (apparently) three characters
+                              --   long and not necessarily numeric.
     , full_name :: String, -- ^ Team full name
     player_listings :: [PlayerListing] }
   deriving (Eq, Show)
@@ -100,7 +104,12 @@ instance DbImport Message where
 
 mkPersist defaultCodegenConfig [groundhog|
 - entity: PlayerListing
-  dbName: injuries_detail
+  dbName: injuries_detail_player_listings
+  constructors:
+    - name: PlayerListing
+      fields:
+        - name: team_id
+          type: varchar(3)
 |]
 
 
@@ -115,7 +124,7 @@ pickle_player_listing =
               (xpElem "Name" xpText)
               (xpElem "Injury" xpText)
               (xpElem "Status" xpText)
-              (xpElem "Fantasy" xpText0)
+              (xpElem "Fantasy" $ xpOption xpText)
               (xpElem "Injured" xpPrim)
               (xpElem "Type" xpText)
   where
@@ -131,8 +140,6 @@ pickle_player_listing =
                    injured pl,
                    injury_type pl)
 
-instance XmlPickler PlayerListing where
-  xpickle = pickle_player_listing
 
 pickle_listing :: PU Listing
 pickle_listing =
@@ -145,9 +152,6 @@ pickle_listing =
     from_tuple = uncurryN Listing
     to_tuple l = (listing_team_id l, full_name l, player_listings l)
 
-instance XmlPickler Listing where
-  xpickle = pickle_listing
-
 
 pickle_message :: PU Message
 pickle_message =
@@ -168,11 +172,12 @@ pickle_message =
                   listings m,
                   time_stamp m)
 
-instance XmlPickler Message where
-  xpickle = pickle_message
-
+--
+-- Tasty Tests
+--
 
--- * Tasty Tests
+-- | A list of all tests for this module.
+--
 injuries_detail_tests :: TestTree
 injuries_detail_tests =
   testGroup
@@ -181,20 +186,34 @@ injuries_detail_tests =
       test_unpickle_succeeds ]
 
 
--- | Warning, succeess of this test does not mean that unpickling
---   succeeded.
+-- | If we unpickle something and then pickle it, we should wind up
+--   with the same thing we started with. WARNING: succeess of this
+--   test does not mean that unpickling succeeded.
+--
 test_pickle_of_unpickle_is_identity :: TestTree
-test_pickle_of_unpickle_is_identity =
-  testCase "pickle composed with unpickle is the identity" $ do
-    let path = "test/xml/Injuries_Detail_XML.xml"
-    (expected :: [Message], actual) <- pickle_unpickle "message" path
-    actual @?= expected
+test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
+  [ check "pickle composed with unpickle is the identity"
+          "test/xml/Injuries_Detail_XML.xml",
+
+    check "pickle composed with unpickle is the identity (non-int team_id)"
+          "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
+  where
+    check desc path = testCase desc $ do
+      (expected, actual) <- pickle_unpickle pickle_message path
+      actual @?= expected
 
 
+-- | Make sure we can actually unpickle these things.
+--
 test_unpickle_succeeds :: TestTree
-test_unpickle_succeeds =
-  testCase "unpickling succeeds" $ do
-  let path = "test/xml/Injuries_Detail_XML.xml"
-  actual <- unpickleable path pickle_message
-  let expected = True
-  actual @?= expected
+test_unpickle_succeeds = testGroup "unpickle tests"
+  [ check "unpickling succeeds"
+          "test/xml/Injuries_Detail_XML.xml",
+
+    check "unpickling succeeds (non-int team_id)"
+          "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
+  where
+    check desc path = testCase desc $ do
+      actual <- unpickleable path pickle_message
+      let expected = True
+      actual @?= expected