More tests for BarAggregator

robocom-zero.cabal

@@ -88,12 +88,14 @@ test-suite robots-test
                      , quickcheck-text
                      , quickcheck-instances
                      , containers
+                     , safe
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
   default-language:    Haskell2010
   other-modules:     Test.RoboCom.Indicators
                    , Test.RoboCom.Positions
                    , Test.RoboCom.Utils
                    , Test.BarAggregator
+                   , ArbitraryInstances
 
 source-repository head
   type:     git

src/ATrade/BarAggregator.hs

@@ -17,6 +17,7 @@ module ATrade.BarAggregator (
   lLastTicks,
   BarAggregator(..),
   mkAggregatorFromBars,
+  handleTicks,
   handleTick,
   handleBar,
   hmsToDiffTime
@@ -54,6 +55,14 @@ lLastTicks = lens lastTicks (\s b -> s { lastTicks = b })
 hmsToDiffTime :: Int -> Int -> Int -> DiffTime
 hmsToDiffTime h m s = secondsToDiffTime $ toInteger $ h * 3600 + m * 60 + s
 
+handleTicks :: [Tick] -> BarAggregator -> ([Bar], BarAggregator)
+handleTicks ticks aggregator = foldl f ([], aggregator) ticks
+  where
+    f (bars', agg) tick = let (mbar, agg') = handleTick tick agg in
+      case mbar of
+        Just bar -> (bar : bars', agg')
+        _        -> (bars', agg')
+
 -- | main logic of bar aggregator
 handleTick :: Tick -> BarAggregator -> (Maybe Bar, BarAggregator)
 handleTick tick = runState $ do

src/ATrade/Driver/Real.hs

@@ -225,6 +225,7 @@ robotMain dataDownloadDelta defaultState initCallback callback = do
     loadStrategyTimers params = case redisSocket params of
       Nothing -> return []
       Just sock -> do
+#ifdef linux_HOST_OS
         conn <- checkedConnect $ defaultConnectInfo { connectPort = UnixSocket sock }
         res <- runRedis conn $ get (encodeUtf8 $ T.pack $ instanceId params ++ "timers")
         case res of
@@ -240,6 +241,9 @@ robotMain dataDownloadDelta defaultState initCallback callback = do
             Nothing -> do
               warningM "main" "Unable to load state"
               return []
+#else
+          error "Not implemented"
+#endif
         
 
     loadStrategyState params = case redisSocket params of

test/ArbitraryInstances.hs

@@ -0,0 +1,111 @@
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE MultiWayIf           #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module ArbitraryInstances (
+) where
+
+
+import           Test.QuickCheck.Instances ()
+import           Test.Tasty.QuickCheck     as QC
+
+import           ATrade.Price              as P
+import           ATrade.Types
+import qualified Data.Text                 as T
+
+import           Data.Time.Calendar
+import           Data.Time.Clock
+
+notTooBig :: (Num a, Ord a) => a -> Bool
+notTooBig x = abs x < 100000000
+
+arbitraryTickerId = arbitrary `suchThat` (\t -> T.all (/= ':') t && t /= "")
+
+instance Arbitrary Tick where
+  arbitrary = Tick <$>
+    arbitraryTickerId <*>
+    arbitrary <*>
+    arbitraryTimestamp <*>
+    arbitrary <*>
+    arbitrary
+
+arbitraryTimestamp = do
+  y <- choose (1970, 2050)
+  m <- choose (1, 12)
+  d <- choose (1, 31)
+
+  sec <- secondsToDiffTime <$> choose (0, 86399)
+
+  return $ UTCTime (fromGregorian y m d) sec
+
+instance Arbitrary DataType where
+  arbitrary = toEnum <$> choose (1, 10)
+
+instance Arbitrary SignalId where
+  arbitrary = SignalId <$> arbitrary <*> arbitrary <*> arbitrary
+
+instance Arbitrary OrderPrice where
+  arbitrary = do
+    v <- choose (1, 4) :: Gen Int
+    if | v == 1 -> return Market
+       | v == 2 -> Limit <$> arbitrary `suchThat` notTooBig
+       | v == 3 -> Stop <$> arbitrary `suchThat` notTooBig <*> arbitrary `suchThat` notTooBig
+       | v == 4 -> StopMarket <$> arbitrary `suchThat` notTooBig
+       | otherwise -> fail "Invalid case"
+
+instance Arbitrary Operation where
+  arbitrary = elements [Buy, Sell]
+
+instance Arbitrary OrderState where
+  arbitrary = elements [Unsubmitted,
+    Submitted,
+    PartiallyExecuted,
+    Executed,
+    Cancelled,
+    Rejected,
+    OrderError ]
+
+instance Arbitrary Order where
+  arbitrary = Order <$>
+    arbitrary <*>
+    arbitrary <*>
+    arbitrary <*>
+    arbitrary <*>
+    arbitrary <*>
+    arbitrary <*>
+    arbitrary <*>
+    arbitrary <*>
+    arbitrary
+
+instance Arbitrary Trade where
+  arbitrary = Trade <$>
+    arbitrary <*>
+    arbitrary <*>
+    arbitrary <*>
+    arbitrary <*>
+    arbitrary <*>
+    arbitrary <*>
+    arbitrary <*>
+    arbitrary <*>
+    arbitrary <*>
+    arbitrary <*>
+    arbitrary
+
+instance Arbitrary P.Price where
+  arbitrary = P.Price <$> (arbitrary `suchThat` (\p -> abs p < 1000000000 * 10000000))
+
+instance Arbitrary Bar where
+  arbitrary = Bar <$>
+    arbitraryTickerId <*>
+    arbitraryTimestamp <*>
+    arbitrary <*>
+    arbitrary <*>
+    arbitrary <*>
+    arbitrary <*>
+    arbitrary `suchThat` (> 0)
+
+instance Arbitrary BarTimeframe where
+  arbitrary = BarTimeframe <$> (arbitrary `suchThat` (\p -> p > 0 && p < 86400 * 365))
+
+

test/Spec.hs

@@ -6,7 +6,7 @@ import qualified Test.RoboCom.Utils
 import           Test.Tasty
 
 main :: IO ()
-main = defaultMain $ testGroup "Tests" [unitTests]
+main = defaultMain $ testGroup "Tests" [unitTests, properties]
 
 unitTests :: TestTree
 unitTests = testGroup "Unit Tests"
@@ -14,3 +14,8 @@ unitTests = testGroup "Unit Tests"
    Test.RoboCom.Positions.unitTests,
    Test.RoboCom.Utils.unitTests,
    Test.BarAggregator.unitTests ]
+
+properties :: TestTree
+properties = testGroup "Properties"
+  [Test.BarAggregator.properties ]
+

test/Test/BarAggregator.hs

@@ -2,22 +2,28 @@
 
 module Test.BarAggregator
 (
-  unitTests
+  unitTests,
+  properties
 ) where
 
 import           ATrade.BarAggregator
 import           ATrade.RoboCom.Types
 import           ATrade.Types
+import           Data.List
 import qualified Data.Map.Strict       as M
 import qualified Data.Text             as T
 import           Data.Time.Calendar
 import           Data.Time.Clock
+import           Safe
 
 import           Test.Tasty
 import           Test.Tasty.HUnit
 import           Test.Tasty.QuickCheck as QC
 import           Test.Tasty.SmallCheck as SC
 
+import           ArbitraryInstances
+
+
 unitTests = testGroup "BarAggregator" [
     testUnknownBarSeries
   , testOneTick
@@ -29,6 +35,10 @@ unitTests = testGroup "BarAggregator" [
   , testNextBarAfterBarClose
   ]
 
+properties = testGroup "BarAggregator" [
+    prop_allTicksInOneBar
+  ]
+
 testUnknownBarSeries :: TestTree
 testUnknownBarSeries = testCase "Tick with unknown ticker id" $ do
   let agg = BarAggregator M.empty M.empty [(0, 86400)]
@@ -181,3 +191,28 @@ testNextBarAfterBarClose = testCase "Three bars (smaller timeframe) - next bar a
             barLow = fromDouble l,
             barClose = fromDouble c,
             barVolume = v }
+
+prop_allTicksInOneBar :: TestTree
+prop_allTicksInOneBar = QC.testProperty "All ticks in one bar" $ QC.forAll (QC.choose (1, 86400)) $ \timeframe ->
+  QC.forAll (QC.listOf1 (genTick "TEST_TICKER" baseTime timeframe)) $ \ticks ->
+        let ticks' = sortOn timestamp ticks in
+          let (newbars, agg) = handleTicks ticks' (mkAggregator "TEST_TICKER" timeframe) in
+            null newbars &&
+            ((barHigh <$> currentBar "TEST_TICKER" agg) == Just (maximum $ value <$> ticks)) &&
+            ((barLow <$> currentBar "TEST_TICKER" agg) == Just (minimum $ value <$> ticks)) &&
+            ((barOpen <$> currentBar "TEST_TICKER" agg) == (value <$> headMay ticks')) &&
+            ((barClose <$> currentBar "TEST_TICKER" agg) == (value <$> lastMay ticks')) &&
+            ((barVolume <$> currentBar "TEST_TICKER" agg) == Just (sum $ volume <$> ticks))
+  where
+    genTick :: T.Text -> UTCTime -> Integer -> Gen Tick
+    genTick tickerId base tf = do
+      difftime <- fromRational . toRational . picosecondsToDiffTime <$> choose (0, truncate 1e12 * tf)
+      val <- arbitrary
+      vol <- arbitrary `suchThat` (> 0)
+      return $ Tick tickerId LastTradePrice (difftime `addUTCTime` baseTime) val vol
+    mkAggregator tickerId tf = mkAggregatorFromBars (M.singleton tickerId (BarSeries tickerId (Timeframe tf) [])) [(0, 86400)]
+
+    currentBar tickerId agg = headMay =<< (bsBars <$> M.lookup tickerId (bars agg))
+    baseTime = UTCTime (fromGregorian 1970 1 1) 0
+
+