executable htsn-import
build-depends:
- ansi-terminal == 0.6.*,
base == 4.*,
cmdargs >= 0.10.6,
configurator == 0.2.*,
groundhog-sqlite == 0.4.*,
groundhog-th == 0.4.*,
old-locale == 1.0.*,
+ tasty == 0.7.*,
+ tasty-hunit == 0.4.*,
time == 1.4.*,
transformers == 0.3.*,
tuple == 0.2.*
-auto-all
-caf-all
+
+test-suite testsuite
+ type: exitcode-stdio-1.0
+ hs-source-dirs: src test
+ main-is: TestSuite.hs
+ build-depends:
+ base == 4.*,
+ cmdargs >= 0.10.6,
+ configurator == 0.2.*,
+ directory == 1.2.*,
+ filepath == 1.3.*,
+ hslogger == 1.2.*,
+ htsn-common == 0.0.1,
+ hxt == 9.3.*,
+ groundhog == 0.4.*,
+ groundhog-postgresql == 0.4.*,
+ groundhog-sqlite == 0.4.*,
+ groundhog-th == 0.4.*,
+ old-locale == 1.0.*,
+ tasty == 0.7.*,
+ tasty-hunit == 0.4.*,
+ time == 1.4.*,
+ transformers == 0.3.*,
+ tuple == 0.2.*
+
+ -- It's not entirely clear to me why I have to reproduce all of this.
+ ghc-options:
+ -Wall
+ -fwarn-hi-shadowing
+ -fwarn-missing-signatures
+ -fwarn-name-shadowing
+ -fwarn-orphans
+ -fwarn-type-defaults
+ -fwarn-tabs
+ -fwarn-incomplete-record-updates
+ -fwarn-monomorphism-restriction
+ -fwarn-unused-do-bind
+ -rtsopts
+ -threaded
+ -optc-O3
+ -optc-march=native
+ -O2
+
+
source-repository head
type: git
location: http://michael.orlitzky.com/git/htsn-import.git
import Text.XML.HXT.Core (
ArrowXml,
IOStateArrow,
- SysConfigList,
XmlPickler,
XmlTree,
(>>>),
getAttrl,
getText,
hasName,
- no,
readDocument,
runX,
unpickleDoc,
- withPreserveComment,
- withRemoveWS,
- withSubstDTDEntities,
- withValidate,
- xpickle,
- yes )
+ xpickle )
import Backend ( Backend(..) )
import CommandLine ( get_args )
Listing ( player_listings ),
Message ( listings ),
PlayerListing )
-
-
-
--- | A list of options passed to 'readDocument' when we parse an XML
--- document. We don't validate because the DTDs from TSN are
--- wrong. As a result, we don't want to keep useless DTDs
--- areound. Thus we disable 'withSubstDTDEntities' which, when
--- combined with "withValidate no", prevents HXT from trying to read
--- the DTD at all.
---
-parse_opts :: SysConfigList
-parse_opts =
- [ withPreserveComment no,
- withRemoveWS yes,
- withSubstDTDEntities no,
- withValidate no ]
+import Xml ( parse_opts )
-- | We put the 'Configuration' and 'XmlTree' arguments last so that
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
--
module TSN.Injuries (
Listing,
- Message( listings ) )
+ Message( listings ),
+ injuries_tests )
where
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(..),
xpWrap )
+import Xml ( pickle_unpickle )
+
+
data Listing =
Listing {
team :: String,
teamno :: Int,
injuries :: String,
updated :: Bool }
- deriving (Show)
+ deriving (Eq, Show)
data Message =
Message {
sport :: String,
listings :: [Listing],
time_stamp :: String }
- deriving (Show)
+ deriving (Eq, Show)
mkPersist defaultCodegenConfig [groundhog|
instance XmlPickler Message where
xpickle = pickle_message
+
+
+
+-- * 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
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module TSN.InjuriesDetail (
Listing ( player_listings ),
Message ( listings ),
- PlayerListing )
+ PlayerListing,
+ injuries_detail_tests )
where
import Data.Time ( UTCTime )
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(..),
xpText0,
xpWrap )
-import TSN.Picklers( xp_date )
+import TSN.Picklers( xp_date, xp_team_id )
+import Xml ( pickle_unpickle )
+
data PlayerListing =
PlayerListing {
injured :: Bool,
injury_type :: String -- ^ "type" is a reserved keyword so we can't use it
}
- deriving (Show)
+ deriving (Eq, Show)
data Listing =
Listing {
listing_team_id :: Int -- ^ Avoid conflict with PlayerListing's team_id
, full_name :: String, -- ^ Team full name
player_listings :: [PlayerListing] }
- deriving (Show)
+ deriving (Eq, Show)
data Message =
Message {
sport :: String,
listings :: [Listing],
time_stamp :: String }
- deriving (Show)
+ deriving (Eq, Show)
mkPersist defaultCodegenConfig [groundhog|
pickle_player_listing =
xpElem "PlayerListing" $
xpWrap (from_tuple, to_tuple) $
- xp10Tuple (xpElem "TeamID" xpPrim)
+ xp10Tuple (xpElem "TeamID" xp_team_id)
(xpElem "PlayerID" xpPrim)
(xpElem "Date" xp_date)
(xpElem "Pos" xpText)
pickle_listing =
xpElem "Listing" $
xpWrap (from_tuple, to_tuple) $
- xpTriple (xpElem "TeamID" xpPrim)
+ xpTriple (xpElem "TeamID" xp_team_id)
(xpElem "FullName" xpText)
(xpList pickle_player_listing)
where
instance XmlPickler Message where
xpickle = pickle_message
+
+
+-- * Tasty Tests
+injuries_detail_tests :: TestTree
+injuries_detail_tests =
+ testGroup
+ "InjuriesDetail 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/Injuries_Detail_XML.xml"
+ (expected :: [Message], actual) <- pickle_unpickle "message" path
+ actual @?= expected
--- /dev/null
+-- | General XML stuff.
+--
+module Xml (
+ parse_opts,
+ pickle_unpickle )
+where
+
+import Text.XML.HXT.Core (
+ (>>>),
+ (/>),
+ SysConfigList,
+ XmlPickler(..),
+ hasName,
+ no,
+ readDocument,
+ runX,
+ withPreserveComment,
+ withRemoveWS,
+ withSubstDTDEntities,
+ withValidate,
+ xpickleVal,
+ xunpickleVal,
+ yes )
+
+-- | A list of options passed to 'readDocument' when we parse an XML
+-- document. We don't validate because the DTDs from TSN are
+-- wrong. As a result, we don't want to keep useless DTDs
+-- areound. Thus we disable 'withSubstDTDEntities' which, when
+-- combined with "withValidate no", prevents HXT from trying to read
+-- the DTD at all.
+--
+parse_opts :: SysConfigList
+parse_opts =
+ [ withPreserveComment no,
+ withRemoveWS yes,
+ withSubstDTDEntities no,
+ withValidate no ]
+
+
+-- | Given a root element name and a file path, return both the
+-- original unpickled root "object" and the one that was constructed
+-- by pickled and unpickling the original. This is used in a number
+-- of XML tests which pickle/unpickle and then make sure that the
+-- output is the same as the input.
+--
+-- We return the object instead of an XmlTree (which would save us
+-- an unpickle call) because otherwise the type of @a@ in the call
+-- to 'xpickle' would be ambiguous. By returning some @a@s, we allow
+-- the caller to annotate its type.
+--
+pickle_unpickle :: XmlPickler a
+ => String
+ -> FilePath
+ -> IO ([a], [a])
+pickle_unpickle root_element filepath = do
+ -- We need to check only the root message element since
+ -- readDocument produces a bunch of other junk.
+ expected <- runX $ arr_getobj
+ actual <- runX $ arr_getobj
+ >>>
+ xpickleVal xpickle
+ >>>
+ xunpickleVal xpickle
+
+ return (expected, actual)
+ where
+ arr_getobj = readDocument parse_opts filepath
+ />
+ hasName root_element
+ >>>
+ xunpickleVal xpickle
--- /dev/null
+import Test.Tasty ( TestTree, defaultMain, testGroup )
+
+import TSN.Injuries ( injuries_tests )
+import TSN.InjuriesDetail ( injuries_detail_tests )
+
+tests :: TestTree
+tests = testGroup
+ "All tests"
+ [ injuries_tests, injuries_detail_tests ]
+
+main :: IO ()
+main = defaultMain tests
projects / dead / htsn-import.git / commitdiff