From: Michael Orlitzky Date: Fri, 10 Jan 2014 04:52:35 +0000 (-0500) Subject: Add an embedded type to TSN.XML.Injuries to allow it to parse the new inferred DTD. X-Git-Tag: 0.0.1~109 X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=778250be6038d4c637e761e132f074e9bb206eaa;p=dead%2Fhtsn-import.git Add an embedded type to TSN.XML.Injuries to allow it to parse the new inferred DTD. --- diff --git a/src/TSN/XML/Injuries.hs b/src/TSN/XML/Injuries.hs index 2ea82c7..bea54d3 100644 --- a/src/TSN/XML/Injuries.hs +++ b/src/TSN/XML/Injuries.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} @@ -19,12 +20,14 @@ module TSN.XML.Injuries ( injuries_tests ) where -import Data.Tuple.Curry ( uncurryN ) +import Data.Data ( Data ) +import Data.Typeable ( Typeable ) import Database.Groundhog() import Database.Groundhog.TH ( defaultCodegenConfig, groundhog, mkPersist ) +import Data.Tuple.Curry ( uncurryN ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( @@ -32,9 +35,12 @@ import Text.XML.HXT.Core ( XmlPickler(..), xp4Tuple, xp6Tuple, + xpAttr, xpElem, xpInt, xpList, + xpOption, + xpPair, xpPrim, xpText, xpWrap ) @@ -44,12 +50,18 @@ import TSN.DbImport ( DbImport(..), import_generic ) import Xml ( pickle_unpickle, unpickleable ) +data InjuriesTeam = + InjuriesTeam { + team_name :: String, + team_league :: Maybe String } + deriving (Data, Eq, Show, Typeable) + data Listing = Listing { - team :: String, - teamno :: Int, + team :: InjuriesTeam, + teamno :: Maybe Int, injuries :: String, - updated :: Bool } + updated :: Maybe Bool } deriving (Eq, Show) data Message = @@ -66,17 +78,40 @@ data Message = mkPersist defaultCodegenConfig [groundhog| - entity: Listing dbName: injuries + constructors: + - name: Listing + fields: + - name: team + embeddedType: + - {name: team_name, dbName: team_name} + - {name: team_league, dbName: team_league} +- embedded: InjuriesTeam + fields: + - name: team_name + - name: team_league |] +pickle_injuries_team :: PU InjuriesTeam +pickle_injuries_team = + xpElem "team" $ + xpWrap (from_tuple, to_tuple) $ + xpPair xpText (xpAttr "league" (xpOption xpText)) + where + from_tuple = uncurryN InjuriesTeam + to_tuple m = (team_name m, team_league m) + +instance XmlPickler InjuriesTeam where + xpickle = pickle_injuries_team + pickle_listing :: PU Listing pickle_listing = xpElem "listing" $ xpWrap (from_tuple, to_tuple) $ - xp4Tuple (xpElem "team" xpText) - (xpElem "teamno" xpInt) + xp4Tuple pickle_injuries_team + (xpOption $ xpElem "teamno" xpInt) (xpElem "injuries" xpText) - (xpElem "updated" xpPrim) + (xpOption $ xpElem "updated" xpPrim) where from_tuple = uncurryN Listing to_tuple l = (team l, teamno l, injuries l, updated l)