content: module TestSuite.Tests.BufferMode (testGroupBufferMode) where
  
  import Data.List (partition)
  import Data.Monoid
  import Test.Tasty
  import Test.HUnit
  import qualified Data.ByteString.UTF8       as S
  import qualified Data.ByteString.Lazy.Char8 as L (unlines)
  
  import IdeSession
  import TestSuite.Assertions
  import TestSuite.Session
  import TestSuite.State
  
  testGroupBufferMode :: TestSuiteEnv -> TestTree
  testGroupBufferMode env = testGroup "Buffer modes" [
      stdTest env "Buffer modes: RunNoBuffering"                                      test_RunNoBuffering
    , stdTest env "Buffer modes: RunLineBuffering, no timeout"                        test_RunLineBuffering_NoTimeout
    , stdTest env "Buffer modes: RunBlockBuffering, no timeout"                       test_RunBlockBuffering_NoTimeout
    , stdTest env "Buffer modes: RunLineBuffering, with timeout"                      test_RunLineBuffering_Timeout
    , stdTest env "Buffer modes: RunBlockBuffering, with timeout"                     test_RunBlockBuffering_Timeout
    , stdTest env "Buffer modes: RunBlockBuffering, buffer never fills, with timeout" test_RunBlockBuffering_Timeout_BufferNeverFills
    ]
  
  test_RunNoBuffering :: TestSuiteEnv -> Assertion
  test_RunNoBuffering env = testBufferMode env RunNoBuffering
  
  test_RunLineBuffering_NoTimeout :: TestSuiteEnv -> Assertion
  test_RunLineBuffering_NoTimeout env = testBufferMode env (RunLineBuffering Nothing)
  
  test_RunBlockBuffering_NoTimeout :: TestSuiteEnv -> Assertion
  test_RunBlockBuffering_NoTimeout env = testBufferMode env (RunBlockBuffering (Just 5) Nothing)
  
  test_RunLineBuffering_Timeout :: TestSuiteEnv -> Assertion
  test_RunLineBuffering_Timeout env = testBufferMode env (RunLineBuffering (Just 1000000))
  
  test_RunBlockBuffering_Timeout :: TestSuiteEnv -> Assertion
  test_RunBlockBuffering_Timeout env = testBufferMode env (RunBlockBuffering (Just 4) (Just 1000000))
  
  test_RunBlockBuffering_Timeout_BufferNeverFills :: TestSuiteEnv -> Assertion
  test_RunBlockBuffering_Timeout_BufferNeverFills env = testBufferMode env (RunBlockBuffering (Just 4096) (Just 1000000))
  
  {-------------------------------------------------------------------------------
    Auxiliary
  -------------------------------------------------------------------------------}
  
  testBufferMode :: TestSuiteEnv -> RunBufferMode -> Assertion
  testBufferMode env bufferMode = withAvailableSession env $ \session -> do
      updateSessionD session upd 1
      assertNoErrors session
  
      runActions <- runStmt session "M" "printCs"
      let go acc = do ret <- runWait runActions
                      case ret of
                        Left bs -> do
                          go (S.toString bs : acc)
                        Right RunOk ->
                          verify bufferMode (reverse acc)
                        Right res ->
                          assertFailure $ "Program terminated abnormally: " ++ show res
      go []
    where
      upd = (updateCodeGeneration True)
         <> (updateStdoutBufferMode bufferMode)
         <> (updateStderrBufferMode bufferMode)
         <> (updateSourceFile "M.hs" . L.unlines $
              [ "module M where"
              , "import Control.Concurrent"
              , "import Control.Monad"
              , "printCs :: IO ()"
              , "printCs = do"
              , "  threadDelay 500000"
              , "  replicateM_ 5 $ do"
              , "    forM_ ['1' .. '9'] $ \\ch -> do"
              , "      threadDelay 100000"
              , "      putChar ch"
              , "    threadDelay 100000"
              , "    putChar '\\n'"
              ])
  
      verify :: RunBufferMode -> [String] -> Assertion
      verify RunNoBuffering outp =
        assertEqual "" (chunk 1 total) outp
      verify (RunLineBuffering Nothing) outp =
        assertEqual "" (chunkOn '\n' total) outp
      verify (RunBlockBuffering (Just blockSize) Nothing) outp =
        assertEqual "" (chunk blockSize total) outp
      verify (RunLineBuffering (Just 1000000)) outp = do
        -- We don't want to be *too* precise, but we should expect 10 chunks,
        -- half of which should end on a linebreak. And of course they should
        -- total to the right thing :)
        let (withBreak, withoutBreak) = partition ((== '\n') . last) outp
        assertEqual "" 5 (length withBreak)
        assertEqual "" 5 (length withoutBreak)
        assertEqual "" total (concat outp)
      verify (RunBlockBuffering (Just 4) (Just 1000000)) outp = do
        -- As above, we don't want to be too precise. Certaily no chunks should
        -- be larger than 4, and "some" should be smaller
        assertBool "" (all ((<= 4) . length) outp)
        assertBool "" (any ((< 4)  . length) outp)
        assertEqual "" total (concat outp)
      verify (RunBlockBuffering (Just 4096) (Just 1000000)) outp = do
        assertEqual "" 6 (length outp)
        assertEqual "" total (concat outp)
      verify mode _outp =
        assertFailure $ "Unsupported mode " ++ show mode
  
      total :: String
      total = concat $ replicate 5 "123456789\n"
  
      chunk :: Int -> [a] -> [[a]]
      chunk _ [] = []
      chunk n xs = let (firstChunk, rest) = splitAt n xs
                   in firstChunk : chunk n rest
  
      chunkOn :: Eq a => a -> [a] -> [[a]]
      chunkOn _ [] = []
      chunkOn x xs = let (firstChunk, rest) = span (/= x) xs
                     in case rest of
                          (x' : rest') -> (firstChunk ++ [x']) : chunkOn x rest'
                          []           -> [firstChunk]
  