From 988f693ce7f1abb6566e75d539ac312b627c31d5 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Sun, 29 Dec 2013 22:55:50 -0500 Subject: [PATCH] Add a tasty test suite and two tests for the existing XML modules. --- htsn-import.cabal | 47 +++++++++++++++++++++++++- src/Main.hs | 26 ++------------ src/TSN/Injuries.hs | 30 +++++++++++++++-- src/TSN/InjuriesDetail.hs | 36 ++++++++++++++++---- src/Xml.hs | 71 +++++++++++++++++++++++++++++++++++++++ test/TestSuite.hs | 12 +++++++ 6 files changed, 187 insertions(+), 35 deletions(-) create mode 100644 src/Xml.hs create mode 100644 test/TestSuite.hs diff --git a/htsn-import.cabal b/htsn-import.cabal index 8e5a9d3..cbec4e6 100644 --- a/htsn-import.cabal +++ b/htsn-import.cabal @@ -14,7 +14,6 @@ description: executable htsn-import build-depends: - ansi-terminal == 0.6.*, base == 4.*, cmdargs >= 0.10.6, configurator == 0.2.*, @@ -28,6 +27,8 @@ executable htsn-import 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.* @@ -60,6 +61,50 @@ executable htsn-import -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 diff --git a/src/Main.hs b/src/Main.hs index e1f4026..b81b6f0 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -23,7 +23,6 @@ import System.IO.Error ( catchIOError ) import Text.XML.HXT.Core ( ArrowXml, IOStateArrow, - SysConfigList, XmlPickler, XmlTree, (>>>), @@ -31,16 +30,10 @@ import Text.XML.HXT.Core ( getAttrl, getText, hasName, - no, readDocument, runX, unpickleDoc, - withPreserveComment, - withRemoveWS, - withSubstDTDEntities, - withValidate, - xpickle, - yes ) + xpickle ) import Backend ( Backend(..) ) import CommandLine ( get_args ) @@ -61,22 +54,7 @@ import qualified TSN.InjuriesDetail as InjuriesDetail ( 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 diff --git a/src/TSN/Injuries.hs b/src/TSN/Injuries.hs index 3877c12..0b19c79 100644 --- a/src/TSN/Injuries.hs +++ b/src/TSN/Injuries.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -14,12 +15,15 @@ -- 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(..), @@ -32,13 +36,16 @@ import Text.XML.HXT.Core ( xpWrap ) +import Xml ( pickle_unpickle ) + + data Listing = Listing { team :: String, teamno :: Int, injuries :: String, updated :: Bool } - deriving (Show) + deriving (Eq, Show) data Message = Message { @@ -48,7 +55,7 @@ data Message = sport :: String, listings :: [Listing], time_stamp :: String } - deriving (Show) + deriving (Eq, Show) mkPersist defaultCodegenConfig [groundhog| @@ -94,3 +101,20 @@ pickle_message = 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 diff --git a/src/TSN/InjuriesDetail.hs b/src/TSN/InjuriesDetail.hs index aa4d7c0..fda6cc8 100644 --- a/src/TSN/InjuriesDetail.hs +++ b/src/TSN/InjuriesDetail.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -19,13 +20,16 @@ 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(..), @@ -39,7 +43,9 @@ import Text.XML.HXT.Core ( xpText0, xpWrap ) -import TSN.Picklers( xp_date ) +import TSN.Picklers( xp_date, xp_team_id ) +import Xml ( pickle_unpickle ) + data PlayerListing = PlayerListing { @@ -54,14 +60,14 @@ data 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 { @@ -71,7 +77,7 @@ data Message = sport :: String, listings :: [Listing], time_stamp :: String } - deriving (Show) + deriving (Eq, Show) mkPersist defaultCodegenConfig [groundhog| @@ -84,7 +90,7 @@ pickle_player_listing :: PU PlayerListing 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) @@ -114,7 +120,7 @@ pickle_listing :: PU Listing 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 @@ -146,3 +152,19 @@ pickle_message = 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 diff --git a/src/Xml.hs b/src/Xml.hs new file mode 100644 index 0000000..129c6e9 --- /dev/null +++ b/src/Xml.hs @@ -0,0 +1,71 @@ +-- | 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 diff --git a/test/TestSuite.hs b/test/TestSuite.hs new file mode 100644 index 0000000..17d9a24 --- /dev/null +++ b/test/TestSuite.hs @@ -0,0 +1,12 @@ +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 -- 2.43.2