X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FInjuries.hs;h=8c2de14b04006e0a954fd156505ec8dc5fa8ae2c;hb=e46de7e95112d4e35219b74c0b3efffe99c69c6a;hp=956aa9d896e0ad8a12fc1f19a843c4f15526c88e;hpb=c99d184584e014aff4953fa8f90c9b3b6dc65229;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/Injuries.hs b/src/TSN/Injuries.hs
index 956aa9d..8c2de14 100644
--- a/src/TSN/Injuries.hs
+++ b/src/TSN/Injuries.hs
@@ -1,22 +1,32 @@
-{-# LANGUAGE EmptyDataDecls #-}
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
-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 ),
+  injuries_tests )
 where
 
-import Database.Persist.TH (
-  mkDeleteCascade,
-  mkMigrate,
-  mkPersist,
-  persistLowerCase,
-  share,
-  sqlOnlySettings )
+import Data.Tuple.Curry ( uncurryN )
+import Database.Groundhog()
+import Database.Groundhog.TH (
+  defaultCodegenConfig,
+  groundhog,
+  mkPersist )
+import Test.Tasty ( TestTree, testGroup )
+import Test.Tasty.HUnit ( (@?=), testCase )
 import Text.XML.HXT.Core (
   PU,
   XmlPickler(..),
@@ -28,62 +38,90 @@ import Text.XML.HXT.Core (
   xpText,
   xpWrap )
 
-import Uncurry (uncurry4, uncurry5, uncurry6)
-
-share [mkPersist sqlOnlySettings,
-       mkDeleteCascade sqlOnlySettings,
-       mkMigrate "migrate_injuries"] [persistLowerCase|
-InjuriesListing
-  team String
-  teamno Int
-  injuries String
-  updated Bool
-  deriving Show
-
-InjuriesMessage
-  xml_file_id Int
-  heading String
-  category String
-  sport String
-  listings [InjuriesListing]
-  time_stamp String
-  deriving Show
+
+import TSN.DbImport ( DbImport(..), import_generic )
+import Xml ( pickle_unpickle )
+
+
+data Listing =
+  Listing {
+    team :: String,
+    teamno :: Int,
+    injuries :: String,
+    updated :: Bool }
+  deriving (Eq, Show)
+
+data Message =
+  Message {
+    xml_file_id :: Int,
+    heading :: String,
+    category :: String,
+    sport :: String,
+    listings :: [Listing],
+    time_stamp :: String }
+  deriving (Eq, Show)
+
+
+mkPersist defaultCodegenConfig [groundhog|
+- entity: Listing
+  dbName: injuries
 |]
 
 
-pickle_injurieslisting :: PU InjuriesListing
-pickle_injurieslisting =
+pickle_listing :: PU Listing
+pickle_listing =
   xpElem "listing" $
-    xpWrap (uncurry4 InjuriesListing,
-            \l -> (injuriesListingTeam l,
-                   injuriesListingTeamno l,
-                   injuriesListingInjuries l,
-                   injuriesListingUpdated 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 InjuriesListing where
-  xpickle = pickle_injurieslisting
+instance XmlPickler Listing where
+  xpickle = pickle_listing
 
 
-pickle_injuriesmessage :: PU InjuriesMessage
-pickle_injuriesmessage =
+pickle_message :: PU Message
+pickle_message =
   xpElem "message" $
-    xpWrap (uncurry6 InjuriesMessage,
-            \m -> (injuriesMessageXml_file_id m,
-                   injuriesMessageHeading m,
-                   injuriesMessageCategory m,
-                   injuriesMessageSport m,
-                   injuriesMessageListings m,
-                   injuriesMessageTime_stamp m)) $
+    xpWrap (from_tuple, to_tuple) $
     xp6Tuple (xpElem "XML_File_ID" xpPrim)
              (xpElem "heading" xpText)
              (xpElem "category" xpText)
              (xpElem "sport" xpText)
-             (xpList pickle_injurieslisting)
+             (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
+
+
+
+instance DbImport Listing where
+  dbimport = import_generic listings
+
+-- * Tasty Tests
+injuries_tests :: TestTree
+injuries_tests =
+  testGroup
+    "Injuries tests"
+    [ test_pickle_of_unpickle_is_identity ]
+
 
-instance XmlPickler InjuriesMessage where
-  xpickle = pickle_injuriesmessage
+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/injuriesxml.xml"
+    (expected :: [Message], actual) <- pickle_unpickle "message" path
+    actual @?= expected