{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import Control.Applicative ((<|>))
import Control.Monad.IO.Class (MonadIO(liftIO))
import qualified Control.Monad.Catch as Ex
import Control.Concurrent.STM
  (STM, atomically, retry,
   TQueue, newTQueueIO, writeTQueue, tryReadTQueue, flushTQueue)
import Data.Foldable (for_, toList)
import Data.Function (fix)
import qualified Data.List as List
import Data.Monoid (Sum(Sum, getSum))
import qualified Data.Time.Clock.System as Time
import qualified Test.Tasty as Tasty
import qualified Test.Tasty.HUnit as HU
import Test.Tasty.HUnit ((@?=), (@=?))
import qualified Test.Tasty.QuickCheck as QC
import qualified Test.Tasty.Runners as Tasty

import qualified Di.Core as Di

--------------------------------------------------------------------------------

main :: IO ()
main = Tasty.defaultMainWithIngredients
  [ Tasty.consoleTestReporter
  , Tasty.listingTests
  ] tt

tt :: Tasty.TestTree
tt = Tasty.testGroup "di-core"
  [ QC.testProperty "log one" $ do
      QC.forAll genLogInt $ \log0 -> do
        QC.ioProperty $ do
          expect [logMeta log0] $ \di0 -> do
             let (l,ps,m) = logMeta log0
             Di.log (pushFifo ps di0) l m

  , QC.testProperty "log many" $ do
      QC.forAll (QC.vectorOf 10 genLogInt) $ \logs0 -> do
        QC.ioProperty $ do
          expect (map logMeta logs0) $ \di0 -> do
            for_ logs0 $ \log_ -> do
              let (l,ps,m) = logMeta log_
              Di.log (pushFifo ps di0) l m

  , HU.testCase "push" $ do
       let x = [(0,[],0), (0,[0],0), (0,[1],0), (0,[1,2],0),
                (0,[1,2],0), (0,[1,2,3],0), (0,[1,2,3],0), (0,[],0)]
       expect x $ \di0 -> do
          Di.log di0 0 0
          -- Identity
          Di.log (Di.push 0 di0) 0 0
          -- Composition
          Di.log (Di.push 1 di0) 0 0
          Di.log ((Di.push 2 . Di.push 1) di0) 0 0
          Di.log (pushFifo [1,2] di0) 0 0
          Di.log ((Di.push 3 . Di.push 2 . Di.push 1) di0) 0 0
          Di.log (pushFifo [1,2,3] di0) 0 0
          -- Checking that di0 still works
          Di.log di0 0 0

  , HU.testCase "contralevel" $ do
       let x = [("1",[],0), ("1",[],0), ("1",[],0),
                ("2",[],0), ("2",[],0), ("1",[],0)]
           n = 1 :: Int
       expect (x :: [(String, [Int], Int)]) $ \di0 -> do
          Di.log di0 "1" 0
          -- Identity
          Di.log (Di.contralevel id di0) "1" 0
          -- Composition
          Di.log (Di.contralevel show di0) n 0
          Di.log ((Di.contralevel succ . Di.contralevel show) di0) n 0
          Di.log (Di.contralevel (show . succ) di0) n 0
          -- Checking that di0 still works
          Di.log di0 "1" 0

  , HU.testCase "contrapath" $ do
       let x = [(0,[],0), (0,["1"],0), (0,["1"],0), (0,["1"],0),
                (0,["2"],0), (0,["2"],0), (0,[],0)]
           n = 1 :: Int
       expect x $ \di0 -> do
          Di.log di0 0 0
          Di.log (Di.push "1" di0) 0 0
          -- Identity
          Di.log (Di.push "1" (Di.contrapath id di0)) 0 0
          -- Composition
          Di.log (Di.push n (Di.contrapath show di0)) 0 0
          Di.log (Di.push n (Di.contrapath (show . succ) di0)) 0 0
          Di.log (Di.push n ((Di.contrapath succ . Di.contrapath show) di0)) 0 0
          -- Checking that di0 still works
          Di.log di0 0 0

  , HU.testCase "contramsg" $ do
       let x = [(0,[],"1"), (0,[],"1"), (0,[],"1"),
                (0,[],"2"), (0,[],"2"), (0,[],"1")]
           n = 1 :: Int
       expect (x :: [(Int,[Int],String)]) $ \di0 -> do
          Di.log di0 0 "1"
          -- Identity
          Di.log (Di.contramsg id di0) 0 "1"
          -- Composition
          Di.log (Di.contramsg show di0) 0 n
          Di.log ((Di.contramsg succ . Di.contramsg show) di0) 0 n
          Di.log (Di.contramsg (show . succ) di0) 0 n
          -- Checking that di0 still works
          Di.log di0 0 "1"

  , HU.testCase "filter" $ do
       let x = [(1,[],"a"), (1,[],"b2"), (1,[],"b4"), (1,[],"b6"),
                (4,[1],"b8"), (4,[1,2],"b10"), (1,[],"c"),
                (3,[],"g"), (3,[],"j"), (3,[],"m"), (1,[],"n")]
       expect (x :: [(Int,[Int],String)]) $ \di0 -> do
          Di.log di0 1 "a"
          -- Predicates
          Di.log (Di.filter (\l ps m -> l /= 1) di0) 1 "b1"
          Di.log (Di.filter (\l ps m -> l == 1) di0) 1 "b2"

          Di.log (Di.filter (\l ps m -> m /= "b3") di0) 1 "b3"
          Di.log (Di.filter (\l ps m -> m == "b4") di0) 1 "b4"

          Di.log (Di.filter (\l ps m -> ps /= []) di0) 1 "b5"
          Di.log (Di.filter (\l ps m -> ps == []) di0) 1 "b6"

          Di.log (Di.push 1 (Di.filter (\l ps m -> ps /= [1]) di0)) 4 "b7"
          Di.log (Di.push 1 (Di.filter (\l ps m -> ps == [1]) di0)) 4 "b8"

          Di.log (Di.push 2 (Di.push 1 (Di.filter (\l ps m -> ps /= [1,2]) di0))) 4 "b9"
          Di.log (Di.push 2 (Di.push 1 (Di.filter (\l ps m -> ps == [1,2]) di0))) 4 "b10"

          -- Identity
          Di.log (Di.filter (\_ _ _ -> True) di0) 1 "c"

          -- Composition
          Di.log ((Di.filter (\l _ _ -> l /= 1) . Di.filter (\l _ _ -> l /= 2)) di0) 1 "e"
          Di.log ((Di.filter (\l _ _ -> l /= 1) . Di.filter (\l _ _ -> l /= 2)) di0) 2 "f"
          Di.log ((Di.filter (\l _ _ -> l /= 1) . Di.filter (\l _ _ -> l /= 2)) di0) 3 "g"
          Di.log (Di.filter (\l _ _ -> l /= 1 && l /= 2) di0) 1 "h"
          Di.log (Di.filter (\l _ _ -> l /= 1 && l /= 2) di0) 2 "i"
          Di.log (Di.filter (\l _ _ -> l /= 1 && l /= 2) di0) 3 "j"
          -- Conmutativity (c.f., "e" "f" "g")
          Di.log ((Di.filter (\l _ _ -> l /= 2) . Di.filter (\l _ _ -> l /= 1)) di0) 1 "k"
          Di.log ((Di.filter (\l _ _ -> l /= 2) . Di.filter (\l _ _ -> l /= 1)) di0) 2 "l"
          Di.log ((Di.filter (\l _ _ -> l /= 2) . Di.filter (\l _ _ -> l /= 1)) di0) 3 "m"
          -- Checking that di0 still works
          Di.log di0 1 "n"

  , HU.testCase "STM" $ do
       let x = [(2,[],"b"), (3,[],"c")] :: [(Int,[Int],String)]
           n = 1 :: Int
       (logs, a) <- withInMemoryDi $ \di0 -> do
          atomically $
             (Di.log' id di0 1 "a" >> retry) <|>
             (Di.log' id di0 2 "b" >> Di.log' id di0 3 "c")
       -- Check that 'retry' prevents logs from being commited.
       x @=? map logMeta logs
       -- Check that the timestamps are not all the same.
       2 @=? List.length (List.nub (List.sort (map Di.log_time logs)))
  ]

--------------------------------------------------------------------------------

withInMemoryDi
  :: (MonadIO m, Ex.MonadMask m)
  => (Di.Di level path msg -> m a)
  -> m ([Di.Log level path msg], a)
withInMemoryDi k = do
  tq :: TQueue (Di.Log level path msg) <- liftIO newTQueueIO
  a <- Di.new (atomically . writeTQueue tq) k
  logs <- liftIO (atomically (flushTQueue tq))
  pure (logs, a)

expect
  :: (MonadIO m, Ex.MonadMask m,
      Eq level, Eq path, Eq msg,
      Show level, Show path, Show msg)
  => [(level, [path], msg)]
  -- ^ Each of the elements matches 'logMeta'.
  -> (Di.Di level path msg -> m a)
  -> m a
expect metas0 k = do
  (logs1, a) <- withInMemoryDi k
  liftIO (metas0 @=? map logMeta logs1)
  pure a

-- | Repeatedly run 'Di.push' on the given paths.
pushFifo
  :: [path]
  -- ^ Paths are in FIFO order. That is, the leftmost @path@ is the
  -- root path.
  -> Di.Di level path msg
  -> Di.Di level path msg
pushFifo [] = id
pushFifo (p:ps) = pushFifo ps . Di.push p

logMeta
  :: Di.Log level path msg
  -> (level, [path], msg)
  -- ^ Paths are in FIFO order. That is, the leftmost @path@ is the
  -- root path.
logMeta x = (Di.log_level x , toList (Di.log_path x) , Di.log_message x)


genLogInt :: QC.Gen (Di.Log Int Int Int)
genLogInt = Di.Log <$> QC.arbitrary <*> QC.arbitrary
                   <*> QC.arbitrary <*> QC.arbitrary

instance QC.Arbitrary Time.SystemTime where
  arbitrary = do
    a <- QC.choose (0, 253402300799) -- up to 4 digit years
    b <- QC.choose (0, 1000000000)
    pure (Time.MkSystemTime a b)