+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
import Data.List.Utils ( join, split )
import Data.Tuple.Curry ( uncurryN )
import Data.Typeable ( Typeable )
+import qualified Data.Vector.HFixed as H ( HVector, convert )
import Database.Groundhog (
countAll,
deleteAll,
insert_,
- migrate,
- runMigration,
- silentMigrationLogger )
+ migrate )
import Database.Groundhog.Core ( DefaultKey )
-import Database.Groundhog.Generic ( runDbConn )
+import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
import Database.Groundhog.Sqlite ( withSqliteConn )
import Database.Groundhog.TH (
groundhog,
mkPersist )
+import qualified GHC.Generics as GHC ( Generic )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
import TSN.Database ( insert_or_select )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
import TSN.Location ( Location(..), pickle_location )
-import TSN.Picklers ( xp_time_stamp )
+import TSN.Picklers ( xp_attr_option, xp_time_stamp )
import TSN.Team ( Team(..) )
import TSN.XmlImport ( XmlImport(..) )
import Xml (
ToDb(..),
pickle_unpickle,
unpickleable,
- unsafe_read_document,
+ unsafe_read_invalid_document,
unsafe_unpickle )
-- prefix here so that the two names don't collide on \"id\" when
-- Groundhog is creating its fields using our field namer.
--
+-- The leading underscores prevent unused field warnings.
+--
data MsgId =
MsgId {
- db_msg_id :: Int,
- db_event_id :: Maybe Int }
- deriving (Data, Eq, Show, Typeable)
+ _db_msg_id :: Int,
+ _db_event_id :: Maybe Int }
+ deriving (Data, Eq, GHC.Generic, Show, Typeable)
+
+-- | For 'H.convert'.
+--
+instance H.HVector MsgId
-- | The XML representation of a news item (\<message\>).
xml_text :: Maybe String, -- Text and continue seem to show up in pairs,
xml_continue :: Maybe String, -- either both present or both missing.
xml_time_stamp :: UTCTime }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector Message
-- | The database representation of a news item. We drop several
-- | We use a record wildcard so GHC doesn't complain that we never
-- used the field names.
--
+ -- To convert, we drop some fields.
+ --
from_xml Message{..} = News { db_xml_file_id = xml_xml_file_id,
db_mid = xml_mid,
db_sport = xml_sport,
data NewsTeamXml =
NewsTeamXml { xml_team_id :: String,
xml_team_name :: String }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector NewsTeamXml
+
instance ToDb NewsTeamXml where
-- | The database representation of 'NewsTeamXml' is 'Team'.
- embedded: MsgId
fields:
- - name: db_msg_id
+ - name: _db_msg_id
dbName: msg_id
- - name: db_event_id
+ - name: _db_event_id
dbName: event_id
- entity: News_Team
pickle_news_team :: PU NewsTeamXml
pickle_news_team =
xpElem "team" $
- xpWrap (from_pair, to_pair) $
+ xpWrap (from_tuple, H.convert) $
xpPair (xpAttr "id" xpText)
xpText -- team name
where
- from_pair :: (String, String) -> NewsTeamXml
- from_pair = uncurry NewsTeamXml
-
- to_pair :: NewsTeamXml -> (String, String)
- to_pair (NewsTeamXml x y) = (x,y)
+ from_tuple = uncurry NewsTeamXml
-- | Convert a 'MsgId' to/from XML.
pickle_msg_id :: PU MsgId
pickle_msg_id =
xpElem "msg_id" $
- xpWrap (from_tuple, to_tuple) $
- xpPair xpInt (xpAttr "EventId" (xpOption xpInt))
+ xpWrap (from_tuple, H.convert) $
+ xpPair xpInt (xpAttr "EventId" xp_attr_option)
where
from_tuple = uncurryN MsgId
- to_tuple m = (db_msg_id m, db_event_id m)
pickle_message :: PU Message
pickle_message =
xpElem "message" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, H.convert) $
xp13Tuple (xpElem "XML_File_ID" xpInt)
(xpElem "heading" xpText)
pickle_msg_id
(xpElem "time_stamp" xp_time_stamp)
where
from_tuple = uncurryN Message
- to_tuple m = (xml_xml_file_id m, -- Verbose,
- xml_heading m, -- but
- xml_mid m, -- eliminates
- xml_category m, -- GHC
- xml_sport m, -- warnings
- xml_url m, -- .
- xml_teams m, -- .
- xml_locations m, -- .
- xml_sms m,
- xml_editor m,
- xml_text m,
- xml_continue m,
- xml_time_stamp m)
+
-- | We combine all of the \<continue\> elements into one 'String'
-- while unpickling and do the reverse while pickling.
let d = undefined :: News_Team
let e = undefined :: News_Location
actual <- withSqliteConn ":memory:" $ runDbConn $ do
- runMigration silentMigrationLogger $ do
+ runMigrationSilent $ do
migrate a
migrate b
migrate c
False ]
where
check path desc expected = testCase desc $ do
- xmltree <- unsafe_read_document path
+ xmltree <- unsafe_read_invalid_document path
let actual = has_only_single_sms xmltree
actual @?= expected