-{-# 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(..),
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