imj-measure-stdout (empty) → 0.1.0.2

raw patch · 7 files changed

+313/−0 lines, 7 filesdep +basedep +imj-preludedep +optparse-applicativesetup-changed

Dependencies added: base, imj-prelude, optparse-applicative

Files

CHANGELOG.md +8/−0
LICENSE +30/−0
README.md +3/−0
Setup.hs +2/−0
app/Main.hs +36/−0
imj-measure-stdout.cabal +46/−0
src/Imj/Measure/Stdout.hs +188/−0

+ CHANGELOG.md view

@@ -0,0 +1,8 @@+# Changelog++This project adheres to [Haskell PVP](https://pvp.haskell.org/).+++## 0.1.0.2 [2018-01-01]++- Initial release

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Olivier Sohn (c) 2017 - 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Olivier Sohn nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,3 @@+# What is it?++A terminal program I wrote to visually determine the maximal size of stdout.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ app/Main.hs view

@@ -0,0 +1,36 @@+module Main where++import           Imj.Prelude++import           Options.Applicative++import           Imj.Measure.Stdout+++otherTestsParser :: Parser Settings+otherTestsParser = OtherTests+      <$> switch+          ( long "modes"+          <> short 'm'+          <> help "Test various buffering modes")++testSizesParser :: Parser Settings+testSizesParser = LengthTest+      <$> option auto+          ( long "size"+         <> short 's'+         <> help ("Tests the maximum capacity of stdout. The size value is expected to be >= 2. "+                  ++ "Looking at your terminal's output, when "+                  ++ "you see 1, then 2, then 3, it means : size > stdout maximum size. "+                  ++ "Else if you see 1, then '2 and 3 at the same time': size < stdout maximum size. "+                 )+         <> metavar "INT" )++main :: IO ()+main =+  testStdout =<< customExecParser p opts+  where+    opts = info ((testSizesParser <|> otherTestsParser) <**> helper)+      ( fullDesc+     <> progDesc "imj-measure-stdout-exe can measure the size of stdout." )+    p = prefs showHelpOnError

+ imj-measure-stdout.cabal view

@@ -0,0 +1,46 @@+name:                imj-measure-stdout+version:             0.1.0.2+Category:            Console, Terminal+Synopsis:            An application to determine the maximum capacity of stdout buffer.+Description:         The program helps you determine the maximum capacity of your stdout buffer.+                     .++                     It was initially developped to diagnose screen tearing issues+                     in a terminal-based game I was developping, and more specifically, to see the+                     effect of the following action :+                     .++                     > hSetBuffering stdout $ BlockBuffering $ Just maxBound+                     .++                     Using this program, I found that, on my system, the previous call quadruples+                     stdout's capacity, from 2048 to 8192 bytes.+homepage:            https://github.com/OlivierSohn/hamazed/blob/master/imj-measure-stdout/README.md+bug-reports:         https://github.com/OlivierSohn/hamazed/issues/+license:             BSD3+license-file:        LICENSE+author:              Olivier Sohn+maintainer:          olivier.sohn@gmail.com+copyright:           2017 - 2018 Olivier Sohn+build-type:          Simple+extra-source-files:  README.md CHANGELOG.md+cabal-version:       >=1.10++Tested-With: GHC == 8.0.2, GHC == 8.2.2++executable imj-measure-stdout-exe+  hs-source-dirs:      app, src+  main-is:             Main.hs+  other-modules:       Imj.Measure.Stdout+  ghc-options:       -Wall -fpedantic-bottoms -Wredundant-constraints+                     -threaded -rtsopts -with-rtsopts=-maxN4+                     -fexcess-precision -optc-ffast-math+  build-depends:       base >= 4.8 && < 4.11+                     , imj-prelude ==0.1.*+                     , optparse-applicative == 0.14.*+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/OlivierSohn/hamazed/+  subdir:   imj-measure-stdout

+ src/Imj/Measure/Stdout.hs view

@@ -0,0 +1,188 @@++module Imj.Measure.Stdout+    ( testStdout+    , testStdoutSize -- for its doc+    , Settings(..)+    -- * Reexports+    ) where++import           Imj.Prelude++import           Control.Concurrent+import           System.IO+++data Settings = LengthTest {+  _settingsLengthTestLength :: !Int+}+               | OtherTests !Bool+++cursorForward, cursorBackward, noop:: String+cursorForward = "\ESC[C"+cursorBackward = "\ESC[D"+noop = cursorForward ++ cursorBackward++-- | Creates a string of given length, whith one visible character,+-- a very big number of no-op escape sequences (cursor forward, cursor backward)+-- and spaces to pad the string to the desired length.+mkSmartStringToExactlyFillBufferOfSize :: Char+                                       -- ^ the char that will be visible+                                       -> Int+                                       -- ^ the length of the string+                                       -> String+mkSmartStringToExactlyFillBufferOfSize char bufferSz =+  let noopSz = length noop+      bufferSzMinusCharSz = pred bufferSz+      countNoops = quot bufferSzMinusCharSz noopSz+      remainingSize = bufferSzMinusCharSz - countNoops * noopSz+      str = replicate remainingSize ' ' ++ [char] ++ concat (replicate countNoops noop)+  in if length str /= bufferSz+       then+         error $ "test logic : " ++ show (str,bufferSz)+       else+         str++{- | A function to visually see if the stdout size is smaller or bigger than given numbers.++@+if you see 1, then 2, then 3,+    size of stdout buffer < size+if you see 1, then 2 and 3 at the same time,+    size of stdout buffer >= size+@++see 'testStdoutSize' doc to understand how to determine the size.+-}+testStdoutSizes :: Int -> IO ()+testStdoutSizes size = do++  when (size <= 1) $ error $ "The size (" ++ show size ++ ") should be >= 2."++  print "test stdout size :"+  print " -if you see 1, then 2, then 3:"+  print $ "    maximum size of stdout buffer < " ++ show size+  print " -if you see 1, then 2 and 3 at the same time:"+  print $ "    maximum size of stdout buffer >= " ++ show size+  -- on my system, 8192 is the stdout max buffer size for+  -- BlockBuffering and LineBuffering modes+  mapM_ testStdoutSize [size]+  putStrLn ""++{- | This function, when run from a process whose stdout is the console,+can be used to visually determine the maximum capacity of stdout.++If stdout capacity >= sz, then in the console we will see++> 1++then++> 1  2  3++Else we see++> 1++then++> 1  2++then++> 1  2  3++There can be "0 to length 'noop'" spaces between chars, they are used+to pad the string sent to the buffer.+-}+testStdoutSize :: Int -> IO ()+testStdoutSize sz = do+  withBufferMode $ BlockBuffering $ Just sz++  let str = mkSmartStringToExactlyFillBufferOfSize '1' sz+      delay = 1000000+  putStr str+  threadDelay delay++  let str' = mkSmartStringToExactlyFillBufferOfSize '2' (pred sz)+  putStr str'+  threadDelay delay++  putChar '3'+  hFlush stdout+  threadDelay delay++withBufferMode :: BufferMode -> IO ()+withBufferMode b = do+  setBufferModeAndVerify b+  bufmode <- hShow stdout+  putStrLn ""+  putStrLn $ "Buffer Mode = " ++ bufmode+  putStrLn ""+  hFlush stdout+++testStdout :: Settings -> IO ()+testStdout (LengthTest candidateLength) = testStdoutSizes candidateLength+testStdout (OtherTests False) = error "missing option (use --help to see the different possibilities)"+testStdout (OtherTests True) = do+  let actions = [+                -- shows that the 'n' in "BlockBuffering (Just n)" is homogenous to+                -- a string length, containing both displayable characters and characters+                -- of escape sequences:+                -- for "BlockBuffering (Just 4)", each flush renders+                --     | cursorforward+                -- for "BlockBuffering (Just 5)", flush renders in alternance:+                --          | cursorforward |+                --          cursorforward | cursorForward+                -- It also shows that the \0 for the end of the string is not stored+                -- in the buffer (ie the length of the buffer used for cursorforward is 3)+                 (putChar '|' >> putStr cursorForward, "putChar '|' >> putStr cursorForward")++                -- shows the effect of buffering on displayable characters+                ,(putChar '|', "putChar '|'")++                -- shows the effect of explicit flushes+                ,(putChar '|' >> hFlush stdout, "putChar '|' >> hFlush stdout")+                ]+  mapM_ (uncurry testAction) actions++testAction :: IO () -> String -> IO ()+testAction action desc = do+  print $ "-- " ++ desc+  let runTests = runActionTests action+      modes =+        [ -- NoBuffering -- it seems equivalent to "BlockBuffering (Just 1)"+          BlockBuffering Nothing+        , BlockBuffering (Just 1)+        , BlockBuffering (Just 2)+        , BlockBuffering (Just 4)+        , BlockBuffering (Just 5)+        , BlockBuffering (Just 8)+        , BlockBuffering (Just 16)+        , LineBuffering+        ]++  mapM_ runTests modes++runActionTests :: IO () -> BufferMode -> IO ()+runActionTests action b = do+  withBufferMode b++  let tenthSecond = 400000+  every tenthSecond action 16++every :: Int -> IO () -> Int -> IO ()+every period action remaining+  | remaining == 0 = return ()+  | otherwise = do+      action+      threadDelay period+      every period action (pred remaining)++setBufferModeAndVerify :: BufferMode -> IO ()+setBufferModeAndVerify b = do+  hSetBuffering stdout b+  b' <- hGetBuffering stdout+  when (b /= b') $ error $ "Failed to set buffering: " ++ show (b,b')+  return ()