Add a tasty test suite and two tests for the existing XML modules.

[dead/htsn-import.git] / src / TSN / Injuries.hs

diff --git a/src/TSN/Injuries.hs b/src/TSN/Injuries.hs
index 7425ab5241025a6273ae9388710cf193ea00ed3b..0b19c792b0b89abcffb120e2855a929ce714daf4 100644 (file)
--- a/src/TSN/Injuries.hs
+++ b/src/TSN/Injuries.hs
@@ -1,76 +1,120 @@
-{-# LANGUAGE EmptyDataDecls #-}
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# 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 ),
+  injuries_tests )
 where
 
-import Generics.Regular
-import Database.Persist.TH
-import Text.XML.HXT.Core
-
-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
+import Data.Tuple.Curry ( uncurryN )
+import Database.Groundhog()
+import Database.Groundhog.TH
+import Test.Tasty ( TestTree, testGroup )
+import Test.Tasty.HUnit ( (@?=), testCase )
+import Text.XML.HXT.Core (
+  PU,
+  XmlPickler(..),
+  xp4Tuple,
+  xp6Tuple,
+  xpElem,
+  xpList,
+  xpPrim,
+  xpText,
+  xpWrap )
+
+
+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_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
+
+
+-- * Tasty Tests
+injuries_tests :: TestTree
+injuries_tests =
+  testGroup
+    "Injuries tests"
+    [ test_pickle_of_unpickle_is_identity ]
+
+
+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