Transaq: changed transaq responses to HKD

src/TXMLConnector/Internal.hs

@@ -33,6 +33,7 @@ import           Control.Concurrent.STM.TBQueue (TBQueue, flushTBQueue,
 import           Control.Monad                  (forM_, void, when)
 import           Control.Monad.Extra            (whileM)
 import qualified Data.Bimap                     as BM
+import           Data.Functor.Identity          (Identity (..))
 import           Data.Maybe                     (catMaybes, fromMaybe, mapMaybe)
 import qualified Data.Text                      as T
 import           Debug.EventCounters            (emitEvent)
@@ -43,8 +44,10 @@ import           Text.XML.Light.Types           (Content (Elem),
                                                  Element (elName),
                                                  QName (qName))
 import           TickTable                      (TickTable, insertTick)
-import           Transaq                        (AllTradesTrade (..),
-                                                 Candle (..), ClientData (..),
+import           Transaq                        (AllTradesTrade,
+                                                 AllTradesTradeB (..), Candle,
+                                                 CandleB (..), ClientData,
+                                                 ClientDataB (..),
                                                  CommandCancelOrder (..),
                                                  CommandChangePass (..),
                                                  CommandConnect (..),
@@ -54,13 +57,15 @@ import           Transaq                        (AllTradesTrade (..),
                                                  CommandSubscribe (..),
                                                  ConnectionState (Disconnected),
                                                  Language (LanguageEn),
-                                                 MarketInfo (..),
-                                                 OrderNotification (..),
-                                                 OrderStatus (..),
-                                                 Quotation (..),
+                                                 MarketInfo, MarketInfoB (..),
+                                                 OrderNotification,
+                                                 OrderNotificationB (..),
+                                                 OrderStatus (..), Quotation,
+                                                 QuotationB (..),
                                                  ResponseAllTrades (ResponseAllTrades),
                                                  ResponseCandleKinds (ResponseCandleKinds),
-                                                 ResponseCandles (..),
+                                                 ResponseCandles,
+                                                 ResponseCandlesB (..),
                                                  ResponseCandlesStatus (StatusPending),
                                                  ResponseClient (ResponseClient),
                                                  ResponseMarkets (ResponseMarkets),
@@ -69,8 +74,10 @@ import           Transaq                        (AllTradesTrade (..),
                                                  ResponseResult (..),
                                                  ResponseSecurities (ResponseSecurities),
                                                  ResponseTrades (ResponseTrades),
-                                                 Security (..), SecurityId (..),
-                                                 TradeNotification (..),
+                                                 Security, SecurityB (..),
+                                                 SecurityId (..),
+                                                 TradeNotification,
+                                                 TradeNotificationB (..),
                                                  TransaqCommand (toXml),
                                                  TransaqResponse (..),
                                                  TransaqResponse (..),
@@ -299,6 +306,10 @@ handleTransaqData transaqData = do
       pure Nothing
     _ -> pure Nothing
   where
+
+    handleTrade :: (MonadIO m,
+                    MonadReader Env m,
+                    HasLog Env Message m) => TradeNotification -> m ()
     handleTrade transaqTrade = do
       brState <- asks brokerState
       trIdMap <- liftIO $ readTVarIO (bsOrderTransactionIdMap brState)
@@ -318,6 +329,8 @@ handleTransaqData transaqData = do
           _ -> log Warning "TXMLConnector.WorkThread" $ "Unable to find order in ordermap: " <> (T.pack . show) transaqTrade
         Nothing -> log Warning "TXMLConnector.WorkThread" "No callback for trade notification!"
 
+
+    fromTransaqTrade :: TradeNotification -> Order -> Maybe TickerInfo -> Trade
     fromTransaqTrade transaqTrade order maybeTickerInfo =
       let vol = case maybeTickerInfo of
             Just tickerInfo -> fromIntegral (tQuantity transaqTrade) * tPrice transaqTrade / tiTickSize tickerInfo * tiTickPrice tickerInfo
@@ -340,6 +353,9 @@ handleTransaqData transaqData = do
     fromDirection Transaq.Buy  = AT.Buy
     fromDirection Transaq.Sell = AT.Sell
 
+    handleOrder :: (MonadIO m,
+                    MonadReader Env m,
+                    HasLog Env Message m) => OrderNotification -> m ()
     handleOrder orderUpdate = do
       brState <- asks brokerState
       trIdMap <- liftIO $ readTVarIO (bsOrderTransactionIdMap brState)
@@ -358,6 +374,7 @@ handleTransaqData transaqData = do
           _ -> log Warning "TXMLConnector.WorkThread" "Unable to find order for order notification"
         Nothing -> log Warning "TXMLConnector.WorkThread" "No callback for order notification"
 
+    orderStateFromTransaq :: OrderNotification -> OrderState
     orderStateFromTransaq orderUpdate =
       case oStatus orderUpdate of
         OrderActive     -> Submitted

src/Transaq.hs

@@ -1,6 +1,12 @@
 {-# LANGUAGE BangPatterns          #-}
+{-# LANGUAGE DeriveAnyClass        #-}
+{-# LANGUAGE DeriveGeneric         #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE StandaloneDeriving    #-}
 
 module Transaq
   (
@@ -19,36 +25,52 @@ module Transaq
     CommandGetHistoryData(..),
     CommandChangePass(..),
     ResponseResult(..),
-    ResponseCandles(..),
-    ResponseServerStatus(..),
+    ResponseCandles,
+    ResponseCandlesB(..),
+    ResponseServerStatus,
+    ResponseServerStatusB(..),
     ResponseCandleKinds(..),
     ResponseMarkets(..),
     ResponseSecurities(..),
-    ResponseSecInfo(..),
+    ResponseSecInfo,
+    ResponseSecInfoB(..),
     ResponseQuotations(..),
     ResponseAllTrades(..),
     ResponseTrades(..),
     ResponseQuotes(..),
     ResponseOrders(..),
     ResponseClient(..),
-    ClientData(..),
-    Quotation(..),
-    Quote(..),
-    TradeNotification(..),
-    OrderNotification(..),
+    ClientData,
+    ClientDataB(..),
+    Quotation,
+    QuotationB(..),
+    Quote,
+    QuoteB(..),
+    TradeNotification,
+    TradeNotificationB(..),
+    OrderNotification,
+    OrderNotificationB(..),
     OrderStatus(..),
-    AllTradesTrade(..),
-    Tick(..),
+    AllTradesTrade,
+    AllTradesTradeB(..),
+    Tick,
+    TickB(..),
     ConnectionState(..),
-    MarketInfo(..),
-    Security(..),
-    CandleKind(..),
+    MarketInfo,
+    MarketInfoB(..),
+    Security,
+    SecurityB(..),
+    CandleKind,
+    CandleKindB(..),
     ResponseCandlesStatus(..),
-    Candle(..),
+    Candle,
+    CandleB(..),
     UnfilledAction(..),
     TradeDirection(..)
   ) where
 
+import           Barbies
+import           Barbies.Bare
 import           Control.Applicative   ((<|>))
 import           Control.Error.Util    (hush)
 import           Control.Monad         (void)
@@ -56,12 +78,14 @@ import           Data.Attoparsec.Text  (Parser, char, decimal, many',
                                         maybeResult, parse, parseOnly,
                                         skipSpace)
 import           Data.Decimal          (DecimalRaw (..))
+import           Data.Functor.Identity (Identity (..))
 import           Data.Int              (Int64)
 import           Data.Maybe            (catMaybes, fromMaybe, mapMaybe,
                                         maybeToList)
 import qualified Data.Text             as T
 import           Data.Time             (fromGregorian)
 import           Data.Time.Clock       (UTCTime (UTCTime))
+import           GHC.Generics
 import           Text.Read             (readMaybe)
 import           Text.XML.Light        (Attr (..), CData (cdData),
                                         Element (elName), Node (..), QName (..),
@@ -122,8 +146,8 @@ parseTimestamp = hush . parseOnly parser
 class TransaqCommand t where
   toXml :: t -> T.Text
 
-class TransaqResponseC t where
-  fromXml :: Element -> Maybe t
+class TransaqResponseC ctx t where
+  fromXml :: ctx -> Maybe t
 
 data CommandConnect =
   CommandConnect
@@ -339,7 +363,7 @@ data ResponseResult =
   | ResponseFailure T.Text
   deriving (Show, Eq, Ord)
 
-instance TransaqResponseC ResponseResult where
+instance TransaqResponseC Element ResponseResult where
   fromXml root =
     if qName (elName root) == "result"
       then
@@ -349,17 +373,27 @@ instance TransaqResponseC ResponseResult where
       else Nothing
 
 
-data Candle =
+data CandleB t f =
   Candle
   {
-    cTimestamp    :: !UTCTime
-  , cOpen         :: !Double
-  , cHigh         :: !Double
-  , cLow          :: !Double
-  , cClose        :: !Double
-  , cVolume       :: !Int
-  , cOpenInterest :: !Int
-  } deriving (Show, Eq, Ord)
+    cTimestamp    :: Wear t f UTCTime
+  , cOpen         :: Wear t f Double
+  , cHigh         :: Wear t f Double
+  , cLow          :: Wear t f Double
+  , cClose        :: Wear t f Double
+  , cVolume       :: Wear t f Int
+  , cOpenInterest :: Wear t f Int
+  } deriving (Generic)
+
+type Candle = CandleB Bare Identity
+
+deriving instance FunctorB (CandleB Covered)
+deriving instance TraversableB (CandleB Covered)
+deriving instance ConstraintsB (CandleB Covered)
+deriving instance Show Candle
+deriving instance Eq Candle
+deriving instance Ord Candle
+deriving instance BareB CandleB
 
 data ResponseCandlesStatus =
     StatusEndOfHistory
@@ -368,14 +402,24 @@ data ResponseCandlesStatus =
   | StatusUnavaliable
   deriving (Show, Eq, Ord)
 
-data ResponseCandles =
+data ResponseCandlesB t f =
   ResponseCandles
   {
-    cPeriodId :: !Int
-  , cStatus   :: !ResponseCandlesStatus
-  , cSecurity :: !SecurityId
-  , cCandles  :: ![Candle]
-  } deriving (Show, Eq, Ord)
+    cPeriodId :: Wear t f Int
+  , cStatus   :: Wear t f ResponseCandlesStatus
+  , cSecurity :: Wear t f SecurityId
+  , cCandles  :: Wear t f [Candle]
+  } deriving (Generic)
+
+type ResponseCandles = ResponseCandlesB Bare Identity
+
+deriving instance FunctorB (ResponseCandlesB Covered)
+deriving instance TraversableB (ResponseCandlesB Covered)
+deriving instance ConstraintsB (ResponseCandlesB Covered)
+deriving instance Show ResponseCandles
+deriving instance Eq ResponseCandles
+deriving instance Ord ResponseCandles
+deriving instance BareB ResponseCandlesB
 
 uname :: String -> QName
 uname x = blank_name {qName = x}
@@ -383,20 +427,20 @@ uname x = blank_name {qName = x}
 childContent :: String -> Element -> Maybe String
 childContent tag el = strContent <$> findChild (uname tag) el
 
-instance TransaqResponseC ResponseCandles where
+instance TransaqResponseC Element (ResponseCandlesB Bare f) where
   fromXml root = do
     !periodId <- findAttr (uname "period") root >>= readMaybe
     !status <- findAttr (uname "status") root >>= readMaybe >>= parseStatus
     !board <- T.pack <$> findAttr (uname "board") root
     !seccode <- T.pack <$> findAttr (uname "seccode") root
     let !candles = mapMaybe parseCandle . elChildren $ root
-    return ResponseCandles
+    return (ResponseCandles
       {
         cPeriodId = periodId
       , cStatus = status
       , cSecurity = SecurityId board seccode
       , cCandles = candles
-      }
+      } :: ResponseCandlesB Bare f)
     where
       parseStatus :: Int -> Maybe ResponseCandlesStatus
       parseStatus intStatus =
@@ -414,7 +458,7 @@ instance TransaqResponseC ResponseCandles where
         !close <- findAttr (uname "close") element >>= readMaybe
         !volume <- findAttr (uname "volume") element >>= readMaybe
         let !openInterest = fromMaybe 0 $ findAttr (uname "oi") element >>= readMaybe
-        return Candle
+        return (Candle
           {
             cTimestamp = timestamp
           , cOpen = open
@@ -423,7 +467,7 @@ instance TransaqResponseC ResponseCandles where
           , cClose = close
           , cVolume = volume
           , cOpenInterest = openInterest
-          }
+          } :: CandleB Bare f)
 
 data ConnectionState =
     Connected
@@ -431,18 +475,28 @@ data ConnectionState =
   | Error T.Text
   deriving (Show, Eq, Ord)
 
-data ResponseServerStatus =
+data ResponseServerStatusB t f =
   ResponseServerStatus
   {
-    serverId       :: !(Maybe Int)
-  , state          :: !ConnectionState
-  , recover        :: !(Maybe Bool)
-  , serverTimezone :: !(Maybe T.Text)
-  , systemVersion  :: !(Maybe Int)
-  , build          :: !(Maybe Int)
-  } deriving (Show, Eq, Ord)
-
-instance TransaqResponseC ResponseServerStatus where
+    serverId       :: Wear t f (Maybe Int)
+  , state          :: Wear t f ConnectionState
+  , recover        :: Wear t f (Maybe Bool)
+  , serverTimezone :: Wear t f (Maybe T.Text)
+  , systemVersion  :: Wear t f (Maybe Int)
+  , build          :: Wear t f (Maybe Int)
+  } deriving (Generic)
+
+type ResponseServerStatus = ResponseServerStatusB Bare Identity
+
+deriving instance FunctorB (ResponseServerStatusB Covered)
+deriving instance TraversableB (ResponseServerStatusB Covered)
+deriving instance ConstraintsB (ResponseServerStatusB Covered)
+deriving instance Show ResponseServerStatus
+deriving instance Eq ResponseServerStatus
+deriving instance Ord ResponseServerStatus
+deriving instance BareB ResponseServerStatusB
+
+instance TransaqResponseC Element ResponseServerStatus where
   fromXml root = do
     let !serverId = findAttr (uname "id") root >>= readMaybe
     !connectedStr <- findAttr (uname "connected") root
@@ -460,16 +514,26 @@ instance TransaqResponseC ResponseServerStatus where
     let !build = findAttr (uname "build") root >>= readMaybe
     pure $ ResponseServerStatus {..}
 
-data MarketInfo =
+data MarketInfoB t f =
   MarketInfo
-  { marketId   :: !Int
-  , marketName :: !T.Text
-  } deriving (Show, Eq, Ord)
+  { marketId   :: Wear t f Int
+  , marketName :: Wear t f T.Text
+  } deriving (Generic)
+
+type MarketInfo = MarketInfoB Bare Identity
+
+deriving instance FunctorB (MarketInfoB Covered)
+deriving instance TraversableB (MarketInfoB Covered)
+deriving instance ConstraintsB (MarketInfoB Covered)
+deriving instance Show MarketInfo
+deriving instance Eq MarketInfo
+deriving instance Ord MarketInfo
+deriving instance BareB MarketInfoB
 
 newtype ResponseMarkets = ResponseMarkets [MarketInfo]
   deriving (Show, Eq, Ord)
 
-instance TransaqResponseC ResponseMarkets where
+instance TransaqResponseC Element ResponseMarkets where
   fromXml root = do
     !markets <- mapM parseMarketInfo $ elChildren root
     pure . ResponseMarkets . catMaybes $ markets
@@ -479,24 +543,34 @@ instance TransaqResponseC ResponseMarkets where
         then do
           !marketId <- findAttr (uname "id") tag >>= readMaybe
           let !marketName = T.pack $ strContent tag
-          pure $ Just $ MarketInfo {..}
+          pure $ Just $ (MarketInfo {..} :: MarketInfo)
         else pure Nothing
 
-data ClientData =
+data ClientDataB t f =
   ClientData
   {
-    cClientId :: !T.Text
-  , cType     :: !T.Text
-  , cCurrency :: !T.Text
-  , cMarket   :: !T.Text
-  , cUnion    :: !T.Text
-  , cForts    :: !(Maybe T.Text)
-  } deriving (Show, Eq, Ord)
+    cClientId :: Wear t f T.Text
+  , cType     :: Wear t f T.Text
+  , cCurrency :: Wear t f T.Text
+  , cMarket   :: Wear t f T.Text
+  , cUnion    :: Wear t f T.Text
+  , cForts    :: Wear t f (Maybe T.Text)
+  } deriving (Generic)
+
+type ClientData = ClientDataB Bare Identity
+
+deriving instance FunctorB (ClientDataB Covered)
+deriving instance TraversableB (ClientDataB Covered)
+deriving instance ConstraintsB (ClientDataB Covered)
+deriving instance Show ClientData
+deriving instance Eq ClientData
+deriving instance Ord ClientData
+deriving instance BareB ClientDataB
 
 newtype ResponseClient = ResponseClient ClientData
   deriving (Show, Eq, Ord)
 
-instance TransaqResponseC ResponseClient where
+instance TransaqResponseC Element ResponseClient where
   fromXml root = if (qName . elName) root == "client"
     then do
       !cClientId <- T.pack <$> findAttr (uname "id") root
@@ -508,19 +582,28 @@ instance TransaqResponseC ResponseClient where
       Just $ ResponseClient $ ClientData {..}
     else Nothing
 
-data CandleKind =
+data CandleKindB t f=
   CandleKind
   {
-    kCandleKindId :: !Int
-  , kPeriod       :: !Int
-  , kName         :: !T.Text
-  } deriving (Show, Eq, Ord)
+    kCandleKindId :: Wear t f Int
+  , kPeriod       :: Wear t f Int
+  , kName         :: Wear t f T.Text
+  } deriving (Generic)
+
+type CandleKind = CandleKindB Bare Identity
+
+deriving instance FunctorB (CandleKindB Covered)
+deriving instance TraversableB (CandleKindB Covered)
+deriving instance ConstraintsB (CandleKindB Covered)
+deriving instance Show CandleKind
+deriving instance Eq CandleKind
+deriving instance Ord CandleKind
+deriving instance BareB CandleKindB
 
 newtype ResponseCandleKinds = ResponseCandleKinds [CandleKind]
   deriving (Show, Eq, Ord)
 
-
-instance TransaqResponseC ResponseCandleKinds where
+instance TransaqResponseC Element ResponseCandleKinds where
   fromXml root = do
     !kinds <- mapM parseCandleKind $ elChildren root
     pure . ResponseCandleKinds . catMaybes $ kinds
@@ -531,33 +614,43 @@ instance TransaqResponseC ResponseCandleKinds where
           !kCandleKindId <- childContent "id" tag >>= readMaybe
           !kPeriod <- childContent "period" tag >>= readMaybe
           !kName <- T.pack <$> childContent "name" tag
-          pure . Just $ CandleKind {..}
+          pure . Just $ (CandleKind {..} :: CandleKind)
         else pure Nothing
 
-data Security =
+data SecurityB t f =
   Security
   {
-    sSecId      :: !Int
-  , sActive     :: !Bool
-  , sSeccode    :: !T.Text
-  , sInstrClass :: !T.Text
-  , sBoard      :: !T.Text
-  , sMarket     :: !T.Text
-  , sCurrency   :: !T.Text
-  , sShortName  :: !T.Text
-  , sDecimals   :: !Int
-  , sMinStep    :: !Double
-  , sLotSize    :: !Int
-  , sLotDivider :: !Int
-  , sPointCost  :: !Double
-  , sSecType    :: !T.Text
-  } deriving (Show, Eq, Ord)
+    sSecId      :: Wear t f Int
+  , sActive     :: Wear t f Bool
+  , sSeccode    :: Wear t f T.Text
+  , sInstrClass :: Wear t f T.Text
+  , sBoard      :: Wear t f T.Text
+  , sMarket     :: Wear t f T.Text
+  , sCurrency   :: Wear t f T.Text
+  , sShortName  :: Wear t f T.Text
+  , sDecimals   :: Wear t f Int
+  , sMinStep    :: Wear t f Double
+  , sLotSize    :: Wear t f Int
+  , sLotDivider :: Wear t f Int
+  , sPointCost  :: Wear t f Double
+  , sSecType    :: Wear t f T.Text
+  } deriving (Generic)
+
+type Security = SecurityB Bare Identity
+
+deriving instance FunctorB (SecurityB Covered)
+deriving instance TraversableB (SecurityB Covered)
+deriving instance ConstraintsB (SecurityB Covered)
+deriving instance Show Security
+deriving instance Eq Security
+deriving instance Ord Security
+deriving instance BareB SecurityB
 
 newtype ResponseSecurities =
   ResponseSecurities [Security]
   deriving (Show, Eq, Ord)
 
-instance TransaqResponseC ResponseSecurities where
+instance TransaqResponseC Element ResponseSecurities where
   fromXml root = do
     securities <- mapM parseSecurity $ elChildren root
     pure . ResponseSecurities . catMaybes $ securities
@@ -579,7 +672,7 @@ instance TransaqResponseC ResponseSecurities where
           !sLotDivider <- childContent "lotdivider" tag >>= readMaybe
           !sPointCost <- childContent "point_cost" tag >>= readMaybe
           !sSecType <- T.pack <$> childContent "sectype" tag
-          pure . Just $ Security {..}
+          pure . Just $ (Security {..} :: Security)
         else
           pure Nothing
 
@@ -588,22 +681,31 @@ instance TransaqResponseC ResponseSecurities where
       parseBool _       = Nothing
 
 
-data ResponseSecInfo =
+data ResponseSecInfoB t f =
   ResponseSecInfo
   {
-    secId         :: !Int
-  , secName       :: !T.Text
-  , secCode       :: !T.Text
-  , market        :: !Int
-  , pname         :: !T.Text
-  , clearingPrice :: !Double
-  , minprice      :: !Double
-  , maxprice      :: !Double
-  , pointCost     :: !Double
-  } deriving (Show, Eq, Ord)
-
-
-instance TransaqResponseC ResponseSecInfo where
+    secId         :: Wear t f Int
+  , secName       :: Wear t f T.Text
+  , secCode       :: Wear t f T.Text
+  , market        :: Wear t f Int
+  , pname         :: Wear t f T.Text
+  , clearingPrice :: Wear t f Double
+  , minprice      :: Wear t f Double
+  , maxprice      :: Wear t f Double
+  , pointCost     :: Wear t f Double
+  } deriving (Generic)
+
+type ResponseSecInfo = ResponseSecInfoB Bare Identity
+
+deriving instance FunctorB (ResponseSecInfoB Covered)
+deriving instance TraversableB (ResponseSecInfoB Covered)
+deriving instance ConstraintsB (ResponseSecInfoB Covered)
+deriving instance Show ResponseSecInfo
+deriving instance Eq ResponseSecInfo
+deriving instance Ord ResponseSecInfo
+deriving instance BareB ResponseSecInfoB
+
+instance TransaqResponseC Element ResponseSecInfo where
   fromXml tag = do
     secId <- findAttr (uname "secid") tag >>= readMaybe
     secName <- T.pack <$> childContent "secname" tag
@@ -616,36 +718,46 @@ instance TransaqResponseC ResponseSecInfo where
     pointCost <- childContent "point_cost" tag >>= readMaybe
     pure ResponseSecInfo {..}
 
-data Quotation =
+data QuotationB t f =
   Quotation
   {
-    qSecId         :: !Int
-  , qBoard         :: !T.Text
-  , qSeccode       :: !T.Text
-  , qOpen          :: !(Maybe Double)
-  , qWaprice       :: !(Maybe Double)
-  , qBidDepth      :: !(Maybe Int)
-  , qBidDepthT     :: !(Maybe Int)
-  , qNumBids       :: !(Maybe Int)
-  , qOfferDepth    :: !(Maybe Int)
-  , qOfferDepthT   :: !(Maybe Int)
-  , qBid           :: !(Maybe Double)
-  , qOffer         :: !(Maybe Double)
-  , qNumOffers     :: !(Maybe Int)
-  , qNumTrades     :: !(Maybe Int)
-  , qVolToday      :: !(Maybe Int)
-  , qOpenPositions :: !(Maybe Int)
-  , qLastPrice     :: !(Maybe Double)
-  , qQuantity      :: !(Maybe Int)
-  , qTimestamp     :: !UTCTime
-  , qValToday      :: !(Maybe Double)
-  } deriving (Show, Eq, Ord)
+    qSecId         :: Wear t f Int
+  , qBoard         :: Wear t f T.Text
+  , qSeccode       :: Wear t f T.Text
+  , qOpen          :: Maybe Double
+  , qWaprice       :: Maybe Double
+  , qBidDepth      :: Maybe Int
+  , qBidDepthT     :: Maybe Int
+  , qNumBids       :: Maybe Int
+  , qOfferDepth    :: Maybe Int
+  , qOfferDepthT   :: Maybe Int
+  , qBid           :: Maybe Double
+  , qOffer         :: Maybe Double
+  , qNumOffers     :: Maybe Int
+  , qNumTrades     :: Maybe Int
+  , qVolToday      :: Maybe Int
+  , qOpenPositions :: Maybe Int
+  , qLastPrice     :: Maybe Double
+  , qQuantity      :: Maybe Int
+  , qTimestamp     :: Wear t f UTCTime
+  , qValToday      :: Maybe Double
+  } deriving (Generic)
+
+type Quotation = QuotationB Bare Identity
+
+deriving instance FunctorB (QuotationB Covered)
+deriving instance TraversableB (QuotationB Covered)
+deriving instance ConstraintsB (QuotationB Covered)
+deriving instance Show Quotation
+deriving instance Eq Quotation
+deriving instance Ord Quotation
+deriving instance BareB QuotationB
 
 newtype ResponseQuotations =
   ResponseQuotations [Quotation]
   deriving (Show, Eq, Ord)
 
-instance TransaqResponseC ResponseQuotations where
+instance TransaqResponseC Element ResponseQuotations where
   fromXml root = do
     quotations <- mapM parseQuotation $ elChildren root
     pure . ResponseQuotations . catMaybes $ quotations
@@ -671,7 +783,7 @@ instance TransaqResponseC ResponseQuotations where
         let !qQuantity = childContent "quantity" tag >>= readMaybe
         !qTimestamp <- childContent "time" tag >>= (parseTimestamp . T.pack)
         let !qValToday = childContent "valToday" tag >>= readMaybe
-        pure $ Just Quotation {..}
+        pure $ Just (Quotation {..} :: Quotation)
 
 data TradingPeriod =
     PeriodOpen
@@ -680,20 +792,30 @@ data TradingPeriod =
   | PeriodUnknown
   deriving (Show, Eq, Ord)
 
-data AllTradesTrade =
+data AllTradesTradeB t f =
   AllTradesTrade
   {
-    attSecId        :: !Int
-  , attSecCode      :: !T.Text
-  , attTradeNo      :: !Int64
-  , attTimestamp    :: !UTCTime
-  , attBoard        :: !T.Text
-  , attPrice        :: !Double
-  , attQuantity     :: !Int
-  , attBuysell      :: !TradeDirection
-  , attOpenInterest :: !Int
-  , attPeriod       :: !TradingPeriod
-  } deriving (Show, Eq, Ord)
+    attSecId        :: Wear t f Int
+  , attSecCode      :: Wear t f T.Text
+  , attTradeNo      :: Wear t f Int64
+  , attTimestamp    :: Wear t f UTCTime
+  , attBoard        :: Wear t f T.Text
+  , attPrice        :: Wear t f Double
+  , attQuantity     :: Wear t f Int
+  , attBuysell      :: Wear t f TradeDirection
+  , attOpenInterest :: Wear t f Int
+  , attPeriod       :: Wear t f TradingPeriod
+  } deriving (Generic)
+
+type AllTradesTrade = AllTradesTradeB Bare Identity
+
+deriving instance FunctorB (AllTradesTradeB Covered)
+deriving instance TraversableB (AllTradesTradeB Covered)
+deriving instance ConstraintsB (AllTradesTradeB Covered)
+deriving instance Show AllTradesTrade
+deriving instance Eq AllTradesTrade
+deriving instance Ord AllTradesTrade
+deriving instance BareB AllTradesTradeB
 
 newtype ResponseAllTrades =
   ResponseAllTrades [AllTradesTrade]
@@ -706,7 +828,7 @@ parseTradeDirection t =
     "S" -> Just Sell
     _   -> Nothing
 
-instance TransaqResponseC ResponseAllTrades where
+instance TransaqResponseC Element ResponseAllTrades where
   fromXml root = do
     alltrades <- mapM parseAllTrade $ elChildren root
     pure . ResponseAllTrades . catMaybes $ alltrades
@@ -722,7 +844,7 @@ instance TransaqResponseC ResponseAllTrades where
         !attBuysell <- T.pack <$> childContent "buysell" tag >>= parseTradeDirection
         let !attOpenInterest = fromMaybe 0 $ childContent "openinterest" tag >>= readMaybe
         let !attPeriod = fromMaybe PeriodUnknown $ childContent "period" tag >>= parseTradingPeriod
-        pure . Just $ AllTradesTrade {..}
+        pure . Just $ (AllTradesTrade {..} :: AllTradesTrade)
 
       parseTradingPeriod :: String -> Maybe TradingPeriod
       parseTradingPeriod "O" = Just PeriodOpen
@@ -731,24 +853,34 @@ instance TransaqResponseC ResponseAllTrades where
       parseTradingPeriod _   = Nothing
 
 
-data Quote =
+data QuoteB t f =
   Quote
   {
-    secId   :: !Int
-  , board   :: !T.Text
-  , secCode :: !T.Text
-  , price   :: !Double
-  , source  :: T.Text
-  , yield   :: !Int
-  , buy     :: !Int
-  , sell    :: !Int
-  } deriving (Show, Eq, Ord)
+    secId   :: Wear t f Int
+  , board   :: Wear t f T.Text
+  , secCode :: Wear t f T.Text
+  , price   :: Wear t f Double
+  , source  :: Wear t f T.Text
+  , yield   :: Wear t f Int
+  , buy     :: Wear t f Int
+  , sell    :: Wear t f Int
+  } deriving (Generic)
+
+type Quote = QuoteB Bare Identity
+
+deriving instance FunctorB (QuoteB Covered)
+deriving instance TraversableB (QuoteB Covered)
+deriving instance ConstraintsB (QuoteB Covered)
+deriving instance Show Quote
+deriving instance Eq Quote
+deriving instance Ord Quote
+deriving instance BareB QuoteB
 
 newtype ResponseQuotes =
   ResponseQuotes [Quote]
   deriving (Show, Eq, Ord)
 
-instance TransaqResponseC ResponseQuotes where
+instance TransaqResponseC Element ResponseQuotes where
   fromXml root = do
     quotes <- mapM parseQuote $ elChildren root
     pure . ResponseQuotes . catMaybes $ quotes
@@ -762,7 +894,7 @@ instance TransaqResponseC ResponseQuotes where
         !yield <- childContent "yield" tag >>= readMaybe
         !buy <- childContent "buy" tag >>= readMaybe
         !sell <- childContent "sell" tag >>= readMaybe
-        return . Just $ Quote {..}
+        return . Just $ (Quote {..} :: Quote)
 
 data OrderStatus =
     OrderActive
@@ -781,31 +913,41 @@ data OrderStatus =
   | OrderWatching
   deriving (Show, Eq, Ord)
 
-data OrderNotification =
+data OrderNotificationB t f =
   OrderNotification
   {
-    oTransactionId :: !Int
-  , oOrderNo       :: !Int64
-  , oSecId         :: !Int
-  , oBoard         :: !T.Text
-  , oSecCode       :: !T.Text
-  , oClient        :: !T.Text
-  , oUnion         :: !T.Text
-  , oStatus        :: !OrderStatus
-  , oBuysell       :: !TradeDirection
-  , oTimestamp     :: !UTCTime
-  , oBrokerRef     :: !T.Text
-  , oBalance       :: !Int
-  , oPrice         :: !Double
-  , oQuantity      :: !Int
-  , oResult        :: !T.Text
-  } deriving (Show, Eq, Ord)
+    oTransactionId :: Wear t f Int
+  , oOrderNo       :: Wear t f Int64
+  , oSecId         :: Wear t f Int
+  , oBoard         :: Wear t f T.Text
+  , oSecCode       :: Wear t f T.Text
+  , oClient        :: Wear t f T.Text
+  , oUnion         :: Wear t f T.Text
+  , oStatus        :: Wear t f OrderStatus
+  , oBuysell       :: Wear t f TradeDirection
+  , oTimestamp     :: Wear t f UTCTime
+  , oBrokerRef     :: Wear t f T.Text
+  , oBalance       :: Wear t f Int
+  , oPrice         :: Wear t f Double
+  , oQuantity      :: Wear t f Int
+  , oResult        :: Wear t f T.Text
+  } deriving (Generic)
+
+type OrderNotification = OrderNotificationB Bare Identity
+
+deriving instance FunctorB (OrderNotificationB Covered)
+deriving instance TraversableB (OrderNotificationB Covered)
+deriving instance ConstraintsB (OrderNotificationB Covered)
+deriving instance Show OrderNotification
+deriving instance Eq OrderNotification
+deriving instance Ord OrderNotification
+deriving instance BareB OrderNotificationB
 
 newtype ResponseOrders =
   ResponseOrders [OrderNotification]
   deriving (Show, Eq, Ord)
 
-instance TransaqResponseC ResponseOrders where
+instance TransaqResponseC Element ResponseOrders where
   fromXml root = do
     quotes <- mapM parseOrder $ elChildren root
     pure . ResponseOrders . catMaybes $ quotes
@@ -826,7 +968,7 @@ instance TransaqResponseC ResponseOrders where
         !oPrice <- childContent "price" tag >>= readMaybe
         !oQuantity <- childContent "quantity" tag >>= readMaybe
         !oResult <- T.pack <$> childContent "result" tag
-        return . Just $ OrderNotification {..}
+        return . Just $ (OrderNotification {..} :: OrderNotification)
       parseStatus "active"     = Just OrderActive
       parseStatus "cancelled"  = Just OrderCancelled
       parseStatus "denied"     = Just OrderDenied
@@ -843,29 +985,39 @@ instance TransaqResponseC ResponseOrders where
       parseStatus "watching"   = Just OrderWatching
       parseStatus _            = Nothing
 
-data TradeNotification =
+data TradeNotificationB t f =
   TradeNotification
   {
-    tSecId     :: !Int
-  , tTradeNo   :: !Int64
-  , tOrderNo   :: !Int64
-  , tBoard     :: !T.Text
-  , tSecCode   :: !T.Text
-  , tClient    :: !T.Text
-  , tUnion     :: !T.Text
-  , tBuysell   :: !TradeDirection
-  , tTimestamp :: !UTCTime
-  , tValue     :: !Double
-  , tComission :: !Double
-  , tQuantity  :: !Int
-  , tPrice     :: !Double
-  } deriving (Show, Eq, Ord)
+    tSecId     :: Wear t f Int
+  , tTradeNo   :: Wear t f Int64
+  , tOrderNo   :: Wear t f Int64
+  , tBoard     :: Wear t f T.Text
+  , tSecCode   :: Wear t f T.Text
+  , tClient    :: Wear t f T.Text
+  , tUnion     :: Wear t f T.Text
+  , tBuysell   :: Wear t f TradeDirection
+  , tTimestamp :: Wear t f UTCTime
+  , tValue     :: Wear t f Double
+  , tComission :: Wear t f Double
+  , tQuantity  :: Wear t f Int
+  , tPrice     :: Wear t f Double
+  } deriving (Generic)
+
+type TradeNotification = TradeNotificationB Bare Identity
+
+deriving instance FunctorB (TradeNotificationB Covered)
+deriving instance TraversableB (TradeNotificationB Covered)
+deriving instance ConstraintsB (TradeNotificationB Covered)
+deriving instance Show TradeNotification
+deriving instance Eq TradeNotification
+deriving instance Ord TradeNotification
+deriving instance BareB TradeNotificationB
 
 newtype ResponseTrades =
   ResponseTrades [TradeNotification]
   deriving (Show, Eq, Ord)
 
-instance TransaqResponseC ResponseTrades where
+instance TransaqResponseC Element ResponseTrades where
   fromXml root = do
     quotes <- mapM parseTrade $ elChildren root
     pure . ResponseTrades . catMaybes $ quotes
@@ -884,22 +1036,32 @@ instance TransaqResponseC ResponseTrades where
         !tComission <- childContent "comission" tag >>= readMaybe
         !tQuantity <- childContent "quantity" tag >>= readMaybe
         !tPrice <- childContent "price" tag >>= readMaybe
-        pure . Just $ TradeNotification {..}
+        pure . Just $ (TradeNotification {..} :: TradeNotification)
 
-data Tick =
+data TickB t f =
   Tick
   {
-    secId        :: !Int
-  , tradeNo      :: !Int64
-  , timestamp    :: !UTCTime
-  , price        :: !Double
-  , quantity     :: !Int
-  , period       :: !TradingPeriod
-  , buySell      :: !TradeDirection
-  , openInterest :: !Int
-  , board        :: !T.Text
-  , secCode      :: !T.Text
-  } deriving (Show, Eq, Ord)
+    secId        :: Wear t f Int
+  , tradeNo      :: Wear t f Int64
+  , timestamp    :: Wear t f UTCTime
+  , price        :: Wear t f Double
+  , quantity     :: Wear t f Int
+  , period       :: Wear t f TradingPeriod
+  , buySell      :: Wear t f TradeDirection
+  , openInterest :: Wear t f Int
+  , board        :: Wear t f T.Text
+  , secCode      :: Wear t f T.Text
+  } deriving (Generic)
+
+type Tick = TickB Bare Identity
+
+deriving instance FunctorB (TickB Covered)
+deriving instance TraversableB (TickB Covered)
+deriving instance ConstraintsB (TickB Covered)
+deriving instance Show Tick
+deriving instance Eq Tick
+deriving instance Ord Tick
+deriving instance BareB TickB
 
 newtype ResponseTicks =
   ResponseTicks [Tick]
@@ -921,7 +1083,8 @@ data TransaqResponse =
   | TransaqResponseTrades ResponseTrades
   deriving (Show, Eq, Ord)
 
-instance TransaqResponseC TransaqResponse where
+
+instance TransaqResponseC Element TransaqResponse where
   fromXml root = case qName . elName $ root of
     "result"        -> TransaqResponseResult <$> fromXml root
     "error"         -> TransaqResponseResult <$> fromXml root

test/Spec.hs

@@ -1,10 +1,15 @@
+import           Debug.EventCounters (initEventCounters)
+import           System.Metrics      (newStore)
 import           Test.Tasty
 
 import qualified Test.FSM
 import qualified Test.TickTable
 
 main :: IO ()
-main = defaultMain $ testGroup "Tests" [unitTests]
+main = do
+  store <- newStore
+  initEventCounters store
+  defaultMain $ testGroup "Tests" [unitTests]
 
 unitTests :: TestTree
 unitTests = testGroup "Unit Tests"

test/Test/Transaq.hs

@@ -0,0 +1,12 @@
+
+module Test.Transaq
+(
+  unitTests
+  ) where
+
+unitTests :: TestTree
+unitTests = testGroup "Parsing"
+  [
+    test
+  ]
+

transaq-connector.cabal

@@ -63,6 +63,8 @@ executable transaq-connector
                      , ekg-core
                      , slave-thread
                      , th-printf
+                     , barbies
+                     , xeno
   extra-lib-dirs:      lib
   ghc-options:         -Wall
                        -Wcompat
@@ -124,6 +126,8 @@ test-suite transaq-connector-test
                      , ekg-statsd
                      , ekg-core
                      , slave-thread
+                     , xeno
+                     , barbies
   default-extensions:  OverloadedStrings
                      , MultiWayIf
                      , MultiParamTypeClasses