├── .gitignore ├── .gitmodules ├── .travis.yml ├── ChangeLog.md ├── Data ├── Array.hs ├── Array │ └── Checked.hs ├── Binary.hs ├── Builder.hs ├── Builder │ └── Internal.hs ├── CBytes.hs ├── Parser.hs ├── Primitive │ ├── BitTwiddle.hs │ ├── PrimArray.hs │ └── PrimArrayQ.hs ├── Text.hs ├── Text │ └── UTF8Codec.hs ├── Textual.hs └── Vector.hs ├── Foreign └── PrimArray.hs ├── GHC └── Stack │ └── Compat.hs ├── LICENSE ├── README.md ├── Setup.hs ├── System ├── IO │ ├── Buffered.hs │ ├── Exception.hs │ ├── FileSystem.hs │ ├── FileSystem │ │ └── Slow.hs │ ├── Log.hs │ ├── Net.hs │ ├── Net │ │ └── SockAddr.hsc │ ├── TTY.hs │ └── UV │ │ ├── Exception.hsc │ │ ├── Internal.hsc │ │ ├── Manager.hs │ │ └── Stream.hs └── LowResTimer.hs ├── appveyor.yml ├── bench ├── BitTwiddle.hs ├── Builder.hs ├── Bytes.hs ├── Main.hs ├── Text.hs ├── diskIO │ ├── AutoFFI.hs │ ├── LICENSE │ ├── README.md │ ├── SafeFFI.hs │ ├── Select.hs │ ├── Setup.hs │ ├── ThreadPool.hs │ ├── UnSafeFFI.hs │ └── diskIO.cabal ├── tcp │ ├── ChangeLog.md │ ├── LICENSE │ ├── LibUV.hs │ ├── MIO.hs │ ├── README.md │ ├── Setup.hs │ ├── golang │ │ └── main.go │ ├── nodejs │ │ └── main.js │ └── tcp.cabal └── timers │ ├── ChangeLog.md │ ├── LICENSE │ ├── LowResTimer.hs │ ├── README.md │ ├── Setup.hs │ ├── SystemTimer.hs │ └── timers.cabal ├── cbits ├── bytes.c ├── hs_uv.c └── text.c ├── docs ├── _config.yml ├── index.md └── stdio │ ├── Data-Array-Checked.html │ ├── Data-Array.html │ ├── Data-Binary.html │ ├── Data-Builder.html │ ├── Data-CBytes.html │ ├── Data-Parser.html │ ├── Data-Primitive-BitTwiddle.html │ ├── Data-Primitive-PrimArray.html │ ├── Data-Primitive-PrimArrayQ.html │ ├── Data-Text-UTF8Codec.html │ ├── Data-Text.html │ ├── Data-Vector.html │ ├── Foreign-PrimArray.html │ ├── GHC-Stack-Compat.html │ ├── System-IO-Buffered.html │ ├── System-IO-Exception.html │ ├── System-IO-FileSystem-Slow.html │ ├── System-IO-FileSystem.html │ ├── System-IO-Net-SockAddr.html │ ├── System-IO-Net.html │ ├── System-IO-TTY.html │ ├── System-IO-UV-Exception.html │ ├── System-IO-UV-Internal.html │ ├── System-IO-UV-Manager.html │ ├── System-IO-UV-Stream.html │ ├── System-LowResTimer.html │ ├── doc-index-126.html │ ├── doc-index-42.html │ ├── doc-index-43.html │ ├── doc-index-45.html │ ├── doc-index-47.html │ ├── doc-index-60.html │ ├── doc-index-61.html │ ├── doc-index-62.html │ ├── doc-index-A.html │ ├── doc-index-All.html │ ├── doc-index-B.html │ ├── doc-index-C.html │ ├── doc-index-D.html │ ├── doc-index-E.html │ ├── doc-index-F.html │ ├── doc-index-G.html │ ├── doc-index-H.html │ ├── doc-index-I.html │ ├── doc-index-K.html │ ├── doc-index-L.html │ ├── doc-index-M.html │ ├── doc-index-N.html │ ├── doc-index-O.html │ ├── doc-index-P.html │ ├── doc-index-Q.html │ ├── doc-index-R.html │ ├── doc-index-S.html │ ├── doc-index-T.html │ ├── doc-index-U.html │ ├── doc-index-V.html │ ├── doc-index-W.html │ ├── doc-index-X.html │ ├── doc-index-Y.html │ ├── doc-index.html │ ├── haddock-util.js │ ├── hslogo-16.png │ ├── index.html │ ├── minus.gif │ ├── ocean.css │ ├── plus.gif │ ├── stdio.haddock │ └── synopsis.png ├── img ├── banner.png └── banner.svg ├── include └── hs_uv.h ├── stack.yaml ├── stdio.cabal └── test ├── Main.hs ├── Property ├── Text.hs └── Vector.hs ├── Unit ├── LowResTimer.hs └── Text.hs └── utf8-sample.txt /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | .HTF/ 21 | stg_dump 22 | *.eventlog 23 | *.stderr 24 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "third_party/libuv"] 2 | path = third_party/libuv 3 | url = https://github.com/haskell-stdio/libuv.git 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # NB: don't set `language: haskell` here 2 | 3 | # explicitly request legacy non-sudo based build environment 4 | sudo: required 5 | 6 | # The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for. 7 | env: 8 | - CABALVER=1.22 GHCVER=7.10.3 9 | - CABALVER=1.24 GHCVER=8.0.2 10 | - CABALVER=1.24 GHCVER=8.2.1 11 | # - CABALVER=head GHCVER=head # see section about GHC HEAD snapshots 12 | 13 | matrix: 14 | allow_failures: 15 | - env: CABALVER=1.22 GHCVER=7.10.3 16 | 17 | # Note: the distinction between `before_install` and `install` is not important. 18 | before_install: 19 | - travis_retry sudo add-apt-repository -y ppa:hvr/ghc 20 | - travis_retry sudo apt-get update 21 | - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER # see note about happy/alex 22 | - git clone https://github.com/libuv/libuv.git && cd libuv && git checkout tags/v1.8.0 && sh autogen.sh && ./configure && make && sudo make install && cd .. 23 | - export PATH=/usr/local/lib:$PATH 24 | - export LD_LIBRARY_PATH=/usr/local/lib:$LD_LIBRARY_PATH 25 | - export EXTRA_OPT="--extra-lib-dirs=/usr/local/include --extra-lib-dirs=/usr/local/lib" 26 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 27 | 28 | install: 29 | - git submodule update --init 30 | - cabal --version 31 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 32 | - travis_retry cabal update 33 | - | 34 | if [[ ${GHCVER} > 8 ]]; then 35 | cabal install --only-dependencies --enable-tests --enable-benchmarks 36 | else 37 | cabal install --only-dependencies # type application which only available on GHC > 8 38 | fi 39 | 40 | # Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail. 41 | script: 42 | - if [ -f configure.ac ]; then autoreconf -i; fi 43 | - | 44 | if [[ ${GHCVER} > 8 ]]; then 45 | cabal configure --enable-tests --enable-benchmarks $EXTRA_OPT -v2 # -v2 provides useful information for debugging 46 | else 47 | cabal configure $EXTRA_OPT -v2 # -v2 provides useful information for debugging 48 | fi 49 | - cabal build # this builds all libraries and executables (including tests/benchmarks) 50 | - | 51 | if [[ ${GHCVER} > 8 ]]; then 52 | cabal test # type application which only available on GHC > 8 53 | fi 54 | # - cabal check 55 | - cabal sdist # tests that a source-distribution can be generated 56 | 57 | # Check that the resulting source distribution can be built & installed. 58 | # If there are no other `.tar.gz` files in `dist`, this can be even simpler: 59 | # `cabal install --force-reinstalls dist/*-*.tar.gz` 60 | - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && 61 | (cd dist && cabal install --force-reinstalls $EXTRA_OPT "$SRC_TGZ") 62 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for stdio 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /Data/Binary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | 4 | module Data.Binary where 5 | 6 | import Data.Array 7 | import Data.Builder 8 | import Data.Parser 9 | import Control.Monad.Primitive (RealWorld) 10 | import Data.Word 11 | import qualified Data.Vector as V 12 | 13 | class Binary a where 14 | binary :: a -> Builder 15 | 16 | class Binary a => PrimPut a where 17 | boundedSize :: a -> Int 18 | boundedWrite :: a -> MutablePrimArray RealWorld Word8 -> Int -> IO Int 19 | 20 | primBinary :: PrimPut a => a -> Builder 21 | primBinary x = atMost (boundedSize x) (boundedWrite x) 22 | {-# INLINE primBinary #-} 23 | 24 | -- | A newtype wrapper for little endian's instances. 25 | -- 26 | newtype LE a = LE a 27 | 28 | -- | Bools are encoded as a byte, 0 for 'False', 1 for 'True'. 29 | instance Binary Bool where binary = primBinary 30 | instance PrimPut Bool where 31 | boundedSize _ = 1 32 | {-# INLINE boundedSize #-} 33 | boundedWrite False marr i = writeArr marr i 1 >> (return $! i+1) 34 | boundedWrite True marr i = writeArr marr i 0 >> (return $! i+1) 35 | {-# INLINE boundedWrite #-} 36 | 37 | instance Binary Word8 where binary = primBinary 38 | instance PrimPut Word8 where 39 | boundedSize _ = 1 40 | {-# INLINE boundedSize #-} 41 | boundedWrite w marr i = writeArr marr i w >> (return $! i+1) 42 | {-# INLINE boundedWrite #-} 43 | 44 | instance Binary V.Bytes where binary = bytes 45 | 46 | 47 | 48 | -------------------------------------------------------------------------------- 49 | 50 | class BinaryParse a where 51 | binaryParse :: Parser a 52 | 53 | 54 | -------------------------------------------------------------------------------- /Data/CBytes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE UnliftedFFITypes #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | 5 | module Data.CBytes where 6 | 7 | import Foreign.C 8 | import Data.Primitive.PrimArray 9 | import Data.Primitive.ByteArray 10 | import Control.Monad.Primitive 11 | import Data.Foldable (foldlM) 12 | import Data.IORef 13 | import Data.Word 14 | import Data.String (IsString(..)) 15 | import Data.Text.UTF8Codec (encodeCBytesChar) 16 | import qualified Data.Vector as V 17 | import GHC.CString 18 | import GHC.Stack.Compat 19 | import GHC.Ptr 20 | import Control.Monad 21 | import Control.Monad.ST 22 | import Data.Bits 23 | import System.IO.Unsafe (unsafeDupablePerformIO) 24 | import qualified System.IO.Exception as E 25 | 26 | -- | A efficient wrapper for null-terminated string which can be automatically freed 27 | -- by ghc garbage collector. 28 | -- 29 | -- The main design target of this type is to ease the bridging of C FFI APIs, since most 30 | -- of the unix APIs use null-terminated string. On windows you're encouraged to use a 31 | -- compatibility layer like 'WideCharToMultiByte/MultiByteToWideChar' and keep the same 32 | -- interface. 33 | -- 34 | -- We neither guarantee to store length info, nor support O(1) slice for 'CBytes': 35 | -- This will defeat the purpose of null-terminated string which is to save memory, 36 | -- and 'strlen' runs very fast. 37 | -- 38 | -- It can be used with @OverloadedString@, literal encoding is UTF-8 with some modifications: 39 | -- @\NUL@ char is encoded to 'C0 80', and '\xD800' ~ '\xDFFF' is encoded as a three bytes 40 | -- normal utf-8 codepoint. This is also how ghc compile string literal into binaries, 41 | -- thus we can use rewrite-rules to construct 'CBytes' value in O(1) without wasting runtime heap. 42 | -- 43 | -- Note most of the unix API is not unicode awared though, you may find a `scandir` call 44 | -- return a filename which is not proper encoded in any unicode encoding at all. 45 | -- But still, UTF-8 is recommanded to be used everywhere, so we use that assumption in 46 | -- various places, such as displaying 'CBytes' and converting literals. 47 | -- 48 | data CBytes 49 | = CBytesOnHeap {-# UNPACK #-} !(MutablePrimArray RealWorld Word8) -- ^ On heap pinned 'MutablePrimArray' 50 | | CBytesLiteral {-# UNPACK #-} !CString -- ^ String literals with static address 51 | 52 | instance Show CBytes where 53 | show = unpackCBytes 54 | 55 | instance Read CBytes where 56 | readsPrec p s = [(packCBytes x, r) | (x, r) <- readsPrec p s] 57 | 58 | instance Eq CBytes where 59 | cbyteA == cbyteB = unsafeDupablePerformIO $ 60 | withCBytes cbyteA $ \ pA -> 61 | withCBytes cbyteB $ \ pB -> 62 | if pA == pB 63 | then return True 64 | else do 65 | r <- c_strcmp pA pB 66 | return (r == 0) 67 | 68 | instance Ord CBytes where 69 | cbyteA `compare` cbyteB = unsafeDupablePerformIO $ 70 | withCBytes cbyteA $ \ pA -> 71 | withCBytes cbyteB $ \ pB -> 72 | if pA == pB 73 | then return EQ 74 | else do 75 | r <- c_strcmp pA pB 76 | return (r `compare` 0) 77 | 78 | instance IsString CBytes where 79 | {-# INLINE fromString #-} 80 | fromString = packCBytes 81 | 82 | {-# RULES 83 | "CBytes packCBytes/unpackCString#" forall addr# . 84 | packCBytes (unpackCString# addr#) = CBytesLiteral (Ptr addr#) 85 | #-} 86 | {-# RULES 87 | "CBytes packCBytes/unpackCStringUtf8#" forall addr# . 88 | packCBytes (unpackCStringUtf8# addr#) = CBytesLiteral (Ptr addr#) 89 | #-} 90 | 91 | -- | Pack a 'String' into null-terminated 'CByte'. 92 | -- 93 | packCBytes :: String -> CBytes 94 | {-# NOINLINE [1] packCBytes #-} 95 | packCBytes s = unsafeDupablePerformIO $ do 96 | mba <- newPrimArray V.defaultInitSize 97 | (SP2 i mba') <- foldlM go (SP2 0 mba) s 98 | writePrimArray mba' i 0 -- the null terminator 99 | shrinkMutablePrimArray mba' (i+1) 100 | return (CBytesOnHeap mba') 101 | where 102 | -- It's critical that this function get specialized and unboxed 103 | -- Keep an eye on its core! 104 | go :: SP2 -> Char -> IO SP2 105 | go (SP2 i mba) !c = do 106 | siz <- sizeofMutablePrimArray mba 107 | if i < siz - 4 -- we need at least 5 bytes for safety due to extra '\0' byte 108 | then do 109 | i' <- encodeCBytesChar mba i c 110 | return (SP2 i' mba) 111 | else do 112 | let !siz' = siz `shiftL` 1 113 | !mba' <- resizeMutablePrimArray mba siz' 114 | i' <- encodeCBytesChar mba' i c 115 | return (SP2 i' mba') 116 | 117 | 118 | data SP2 = SP2 {-# UNPACK #-}!Int {-# UNPACK #-}!(MutablePrimArray RealWorld Word8) 119 | 120 | unpackCBytes :: CBytes -> String 121 | {-# INLINABLE unpackCBytes #-} 122 | unpackCBytes cbytes = unsafeDupablePerformIO . withCBytes cbytes $ \ (Ptr addr#) -> 123 | return (unpackCStringUtf8# addr#) 124 | 125 | -------------------------------------------------------------------------------- 126 | 127 | -- | Copy a 'CString' type into a 'CBytes', return Nothing if the pointer is NULL. 128 | -- 129 | -- After copying you're free to free the 'CString' 's memory. 130 | -- 131 | fromCStringMaybe :: HasCallStack => CString -> IO (Maybe CBytes) 132 | {-# INLINABLE fromCStringMaybe #-} 133 | fromCStringMaybe cstring = do 134 | if cstring == nullPtr 135 | then return Nothing 136 | else do 137 | len <- c_strlen cstring 138 | mpa@(MutablePrimArray (MutableByteArray mba#)) <- newPinnedPrimArray (fromIntegral len+1) 139 | c_strcpy mba# cstring 140 | return (Just (CBytesOnHeap mpa)) 141 | 142 | 143 | -- | Same with 'fromCString', but throw 'E.InvalidArgument' when meet a null pointer. 144 | -- 145 | fromCString :: HasCallStack 146 | => CString 147 | -> IO CBytes 148 | {-# INLINABLE fromCString #-} 149 | fromCString cstring = do 150 | if cstring == nullPtr 151 | then E.throwIO (E.InvalidArgument 152 | (E.IOEInfo "" "unexpected null pointer" callStack)) 153 | else do 154 | len <- c_strlen cstring 155 | mpa@(MutablePrimArray (MutableByteArray mba#)) <- newPinnedPrimArray (fromIntegral len+1) 156 | c_strcpy mba# cstring 157 | return (CBytesOnHeap mpa) 158 | 159 | -- | Pass 'CBytes' to foreign function as a @char*@. 160 | -- 161 | withCBytes :: CBytes -> (CString -> IO a) -> IO a 162 | {-# INLINABLE withCBytes #-} 163 | withCBytes (CBytesOnHeap mba) f = withMutablePrimArrayContents mba (f . castPtr) 164 | withCBytes (CBytesLiteral ptr) f = f ptr 165 | 166 | -------------------------------------------------------------------------------- 167 | 168 | foreign import ccall unsafe "string.h strcmp" 169 | c_strcmp :: CString -> CString -> IO CInt 170 | 171 | foreign import ccall unsafe "string.h strlen" 172 | c_strlen :: CString -> IO CSize 173 | 174 | foreign import ccall unsafe "string.h strcpy" 175 | c_strcpy :: MutableByteArray# RealWorld -> CString -> IO () 176 | 177 | -------------------------------------------------------------------------------- /Data/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE CPP #-} 4 | 5 | module Data.Parser where 6 | 7 | import qualified Data.Vector as V 8 | #if MIN_VERSION_base(4,9,0) 9 | import qualified Control.Monad.Fail as Fail 10 | #endif 11 | import Control.Monad 12 | import Control.Applicative 13 | 14 | 15 | -- | Simple parsing result, that represent respectively: 16 | -- 17 | -- * failure: with the error message 18 | -- 19 | -- * continuation: that need for more inp data 20 | -- 21 | -- * success: the remaining unparsed data and the parser value 22 | -- 23 | data Result a 24 | = Success !V.Bytes a 25 | | Failure !V.Bytes [String] 26 | | NeedMore (Maybe V.Bytes -> Result a) 27 | 28 | instance Functor Result where 29 | fmap f (Success s a) = Success s (f a) 30 | fmap _ (Failure s msg) = Failure s msg 31 | fmap f (NeedMore k) = NeedMore (fmap f . k) 32 | 33 | instance Show a => Show (Result a) where 34 | show (Failure _ errs) = "ParseFailure: " ++ show errs 35 | show (NeedMore _) = "NeedMore _" 36 | show (Success _ a) = "ParseOK " ++ show a 37 | 38 | -- | Simple parser structure 39 | newtype Parser a = Parser 40 | { runParser :: forall r . V.Bytes 41 | -> (V.Bytes -> a -> Result r) -- The success continuation 42 | -> Result r -- We don't need failure continuation 43 | } -- since the failure is written on the ParseResult tag 44 | 45 | 46 | instance Monad Parser where 47 | return = pure 48 | {-# INLINE return #-} 49 | Parser pa >>= f = Parser (\ inp k -> pa inp (\ inp' a -> runParser (f a) inp' k)) 50 | {-# INLINE (>>=) #-} 51 | #if MIN_VERSION_base(4,9,0) 52 | fail = Fail.fail 53 | instance Fail.MonadFail Parser where 54 | #endif 55 | fail str = Parser (\ inp _ -> Failure inp [str]) 56 | {-# INLINE fail #-} 57 | 58 | instance Applicative Parser where 59 | pure x = Parser (\ inp k -> k inp x) 60 | {-# INLINE pure #-} 61 | pf <*> pa = do { f <- pf; a <- pa; return (f a) } 62 | {-# INLINE (<*>) #-} 63 | 64 | instance Functor Parser where 65 | fmap f (Parser pa) = Parser (\ inp k -> pa inp (\ inp' a -> k inp' (f a))) 66 | {-# INLINE fmap #-} 67 | a <$ Parser pb = Parser (\ inp k -> pb inp (\ inp' _ -> k inp' a)) 68 | {-# INLINE (<$) #-} 69 | 70 | instance MonadPlus Parser where 71 | mzero = empty 72 | mplus = (<|>) 73 | 74 | instance Alternative Parser where 75 | empty = Parser (\ inp _ -> Failure inp ["Data.Parser(Alternative).empty"]) 76 | {-# INLINE empty #-} 77 | f <|> g = do 78 | (r, bs) <- runAndKeepTrack f 79 | case r of 80 | Success inp x -> Parser (\ _ k -> k inp x) 81 | Failure _ _ -> pushBack bs >> g 82 | _ -> error "Binary: impossible" 83 | {-# INLINE (<|>) #-} 84 | 85 | -- | Run a parser and keep track of all the inp it consumes. 86 | -- Once it's finished, return the final result (always 'Success' or 'Failure') and 87 | -- all consumed chunks. 88 | -- 89 | runAndKeepTrack :: Parser a -> Parser (Result a, [V.Bytes]) 90 | runAndKeepTrack (Parser pa) = Parser $ \ inp k0 -> 91 | let r0 = pa inp (\ inp' a -> Success inp' a) in go [] r0 k0 92 | where 93 | go !acc r k0 = case r of 94 | NeedMore k -> NeedMore (\ minp -> go (maybe acc (:acc) minp) (k minp) k0) 95 | Success inp' _ -> k0 inp' (r, reverse acc) 96 | Failure inp' _ -> k0 inp' (r, reverse acc) 97 | {-# INLINE runAndKeepTrack #-} 98 | 99 | pushBack :: [V.Bytes] -> Parser () 100 | pushBack [] = Parser (\ inp k -> k inp ()) 101 | pushBack bs = Parser (\ inp k -> k (V.concat (inp : bs)) ()) 102 | {-# INLINE pushBack #-} 103 | 104 | {- 105 | parse :: V.Bytes -> Parser a -> Result a 106 | parse input (Parser p) = p input (\ input' a -> Success input' a) 107 | 108 | -- | Ensure that there are at least @n@ bytes available. If not, the 109 | -- computation will escape with 'Partial'. 110 | ensureN :: Int -> Parser () 111 | ensureN !n0 = C $ \inp ks -> do 112 | if V.length inp >= n0 113 | then ks inp () 114 | else runCont (withInputChunks n0 enoughChunks onSucc onFail >>= put) inp ks 115 | where -- might look a bit funny, but plays very well with GHC's inliner. 116 | -- GHC won't inline recursive functions, so we make ensureN non-recursive 117 | enoughChunks n str 118 | | V.length str >= n = Right (str,V.empty) 119 | | otherwise = Left (n - V.length str) 120 | -- Sometimes we will produce leftovers lists of the form [V.empty, nonempty] 121 | -- where `nonempty` is a non-empty ByteString. In this case we can avoid a copy 122 | -- by simply dropping the empty prefix. In principle ByteString might want 123 | -- to gain this optimization as well 124 | onSucc = V.concat . dropWhile V.null 125 | onFail bss = C $ \_ _ -> Failure (V.concat bss) "not enough bytes" 126 | -} 127 | -------------------------------------------------------------------------------- /Data/Primitive/BitTwiddle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE MagicHash #-} 3 | 4 | -- | This module implement some bit twiddling with ghc primitives. 5 | -- 6 | -- We currently didn't use all functions from this module though: the performance is not 7 | -- catching up c version yet. But this module and relevant benchmarks are kept in hope 8 | -- that once we have fully SIMD support in GHC, we might optimize these functions further 9 | -- to compete with c. 10 | -- 11 | -- Reference: 12 | -- 13 | -- * https://graphics.stanford.edu/~seander/bithacks.html 14 | -- * https://jameshfisher.github.io/2017/01/24/bitwise-check-for-zero-byte.html 15 | -- 16 | -- 17 | module Data.Primitive.BitTwiddle where 18 | 19 | import GHC.Prim 20 | import GHC.Types 21 | import GHC.Word 22 | import Data.Primitive.PrimArray 23 | import Data.Primitive.ByteArray 24 | 25 | -- we need to know word size 26 | #include "MachDeps.h" 27 | 28 | #if SIZEOF_HSWORD == 4 29 | # define CAST_OFFSET_WORD_TO_BYTE(x) (x `uncheckedIShiftL#` 2#) 30 | # define CAST_OFFSET_BYTE_TO_WORD(x) (x `uncheckedIShiftRA#` 2#) 31 | #else 32 | # define CAST_OFFSET_WORD_TO_BYTE(x) (x `uncheckedIShiftL#` 3#) 33 | # define CAST_OFFSET_BYTE_TO_WORD(x) (x `uncheckedIShiftRA#` 3#) 34 | #endif 35 | 36 | isOffsetAligned# :: Int# -> Bool 37 | {-# INLINE isOffsetAligned# #-} 38 | isOffsetAligned# s# = isTrue# ((SIZEOF_HSWORD# -# 1#) `andI#` s# ==# 0#) 39 | 40 | mkMask# :: Word# -> Word# 41 | {-# INLINE mkMask# #-} 42 | mkMask# w8# = 43 | #if SIZEOF_HSWORD == 4 44 | let w16# = w8# `or#` (w8# `uncheckedShiftL#` 8#) 45 | in w16# `or#` (w16# `uncheckedShiftL#` 16#) 46 | #else 47 | let w16# = w8# `or#` (w8# `uncheckedShiftL#` 8#) 48 | w32# = w16# `or#` (w16# `uncheckedShiftL#` 16#) 49 | in w32# `or#` (w32# `uncheckedShiftL#` 32#) 50 | #endif 51 | 52 | -- https://jameshfisher.github.io/2017/01/24/bitwise-check-for-zero-byte.html 53 | -- 54 | nullByteMagic# :: Word# -> Word# 55 | {-# INLINE nullByteMagic# #-} 56 | nullByteMagic# w# = 57 | #if SIZEOF_HSWORD == 4 58 | (w# `minusWord#` 0x01010101##) `and#` (not# w#) `and#` 0x80808080## 59 | #else 60 | (w# `minusWord#` 0x0101010101010101##) `and#` (not# w#) `and#` 0x8080808080808080## 61 | #endif 62 | 63 | -- | Search a word8 in array. 64 | -- 65 | -- Currently this function is ~4 times slow than c version, so we didn't use it. 66 | -- 67 | memchr :: PrimArray Word8 -- array 68 | -> Word8 -- target 69 | -> Int -- start offset 70 | -> Int -- search length 71 | -> Int 72 | {-# INLINE memchr #-} 73 | memchr (PrimArray (ByteArray ba#)) (W8# c#) (I# s#) (I# siz#) = 74 | I# (memchr# ba# c# s# siz#) 75 | 76 | -- | The unboxed version of 'memchr' 77 | -- 78 | memchr# :: ByteArray# -> Word# -> Int# -> Int# -> Int# 79 | {-# NOINLINE memchr# #-} 80 | memchr# ba# c# s# siz# = beforeAlignedLoop# ba# c# s# (s# +# siz#) 81 | where 82 | beforeAlignedLoop# :: ByteArray# -> Word# -> Int# -> Int# -> Int# 83 | beforeAlignedLoop# ba# c# s# end# 84 | | isTrue# (s# >=# end#) = -1# 85 | | isTrue# (c# `eqWord#` indexWord8Array# ba# s#) = s# 86 | | isOffsetAligned# s# = alignedLoop# ba# (mkMask# c#) 87 | CAST_OFFSET_BYTE_TO_WORD(s#) 88 | CAST_OFFSET_BYTE_TO_WORD(end#) 89 | end# 90 | | otherwise = beforeAlignedLoop# ba# c# (s# +# 1#) end# 91 | 92 | alignedLoop# :: ByteArray# -> Word# -> Int# -> Int# -> Int# -> Int# 93 | alignedLoop# ba# mask# s# end# end_# 94 | | isTrue# (s# >=# end#) = afterAlignedLoop# ba# (mask# `and#` 0xFF##) 95 | CAST_OFFSET_WORD_TO_BYTE(s#) 96 | end_# 97 | | otherwise = case indexWordArray# ba# s# of 98 | w# -> 99 | case nullByteMagic# (mask# `xor#` w#) of 100 | 0## -> alignedLoop# ba# mask# (s# +# 1#) end# end_# 101 | _ -> afterAlignedLoop# ba# (mask# `and#` 0xFF##) 102 | CAST_OFFSET_WORD_TO_BYTE(s#) 103 | end_# 104 | 105 | afterAlignedLoop# :: ByteArray# -> Word# -> Int# -> Int# -> Int# 106 | afterAlignedLoop# ba# c# s# end# 107 | | isTrue# (s# >=# end#) = -1# 108 | | isTrue# (c# `eqWord#` indexWord8Array# ba# s#) = s# 109 | | otherwise = afterAlignedLoop# ba# c# (s# +# 1#) end# 110 | 111 | -- | Search a word8 array in reverse order. 112 | -- 113 | -- This function is used in @elemIndexEnd@, since there's no c equivalent. 114 | -- 115 | memchrReverse :: PrimArray Word8 -- array 116 | -> Word8 -- target 117 | -> Int -- start offset 118 | -> Int -- search length 119 | -> Int 120 | {-# INLINE memchrReverse #-} 121 | memchrReverse (PrimArray (ByteArray ba#)) (W8# c#) (I# s#) (I# siz#) = 122 | I# (memchr# ba# c# s# siz#) 123 | 124 | -- | The unboxed version of 'memchrReverse' 125 | -- 126 | memchrReverse# :: ByteArray# -> Word# -> Int# -> Int# -> Int# 127 | {-# NOINLINE memchrReverse# #-} 128 | memchrReverse# ba# c# s# siz# = beforeAlignedLoop# ba# c# s# (s# -# siz#) 129 | where 130 | beforeAlignedLoop# :: ByteArray# -> Word# -> Int# -> Int# -> Int# 131 | beforeAlignedLoop# ba# c# s# end# 132 | | isTrue# (s# <# end#) = -1# 133 | | isTrue# (c# `eqWord#` indexWord8Array# ba# s#) = s# 134 | | isOffsetAligned# s# = alignedLoop# ba# (mkMask# c#) 135 | CAST_OFFSET_BYTE_TO_WORD(s#) 136 | CAST_OFFSET_BYTE_TO_WORD(end#) 137 | end# 138 | | otherwise = beforeAlignedLoop# ba# c# (s# -# 1#) end# 139 | 140 | alignedLoop# :: ByteArray# -> Word# -> Int# -> Int# -> Int# -> Int# 141 | alignedLoop# ba# mask# s# end# end_# 142 | | isTrue# (s# <# end#) = afterAlignedLoop# ba# (mask# `and#` 0xFF##) 143 | CAST_OFFSET_WORD_TO_BYTE(s#) 144 | end_# 145 | | otherwise = case indexWordArray# ba# s# of 146 | w# -> 147 | case nullByteMagic# (mask# `xor#` w#) of 148 | 0## -> alignedLoop# ba# mask# (s# -# 1#) end# end_# 149 | _ -> afterAlignedLoop# ba# (mask# `and#` 0xFF##) 150 | CAST_OFFSET_WORD_TO_BYTE(s#) 151 | end_# 152 | 153 | afterAlignedLoop# :: ByteArray# -> Word# -> Int# -> Int# -> Int# 154 | afterAlignedLoop# ba# c# s# end# 155 | | isTrue# (s# <# end#) = -1# 156 | | isTrue# (c# `eqWord#` indexWord8Array# ba# s#) = s# 157 | | otherwise = afterAlignedLoop# ba# c# (s# -# 1#) end# 158 | -------------------------------------------------------------------------------- /Data/Primitive/PrimArrayQ.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE MagicHash #-} 5 | {-# LANGUAGE CPP #-} 6 | {-# LANGUAGE BangPatterns #-} 7 | 8 | module Data.Primitive.PrimArrayQ where 9 | 10 | #include "MachDeps.h" 11 | 12 | import Language.Haskell.TH 13 | import Language.Haskell.TH.Quote 14 | import GHC.Word 15 | import GHC.Types 16 | import GHC.Prim 17 | import Control.Monad 18 | import Data.Char (ord) 19 | import Data.Bits 20 | import System.IO.Unsafe 21 | import Data.Array 22 | import Data.Primitive.PrimArray 23 | import GHC.Ptr 24 | 25 | asciiLiteral :: (Int -> ExpQ -> ExpQ) -> String -> ExpQ 26 | asciiLiteral k str = k (length str) $ (LitE . StringPrimL) `fmap` check str 27 | where 28 | check :: String -> Q [Word8] 29 | check [] = return [] 30 | check (c:cs) = do 31 | when (ord c > 0xFF) $ 32 | reportError $ "character '" ++ [c] ++ "' is have out of range in ASCII literal:" ++ str 33 | cs' <- check cs 34 | return (fromIntegral (ord c):cs') 35 | 36 | asciiLiteralMulLine :: (Int -> ExpQ -> ExpQ) -> String -> ExpQ 37 | asciiLiteralMulLine k str = k (length str) $ (LitE . StringPrimL) `fmap` check str 38 | where 39 | check :: String -> Q [Word8] 40 | check [] = return [] 41 | check (c:cs) = do 42 | when (ord c > 0xFF) $ 43 | reportWarning $ "character '" ++ [c] ++ "' is out of ASCII range in literal:" ++ str 44 | cs' <- check cs 45 | return (fromIntegral (ord c):cs') 46 | 47 | 48 | utf8Literal :: (Int -> ExpQ -> ExpQ) -> String -> ExpQ 49 | utf8Literal = undefined 50 | 51 | -------------------------------------------------------------------------------- 52 | 53 | vectorLiteral :: ([Integer] -> Q [Word8]) -> (Int -> ExpQ -> ExpQ) -> String -> ExpQ 54 | vectorLiteral f k str = do 55 | (len, ws) <- parse str 56 | k len $ (return . LitE . StringPrimL) ws 57 | where 58 | parse :: String -> Q (Int, [Word8]) 59 | parse str = do 60 | case (readList :: ReadS [Integer]) ("[" ++ str ++ "]") of 61 | [(is, "")] -> (length is, ) `fmap` f is 62 | _ -> do reportError $ "can't parse vector literal:" ++ str 63 | return (0, []) 64 | 65 | word16LiteralLE :: (Int -> ExpQ -> ExpQ) -> String -> ExpQ 66 | word16LiteralLE k str = vectorLiteral mkWord16LE k str 67 | where 68 | mkWord16LE :: [Integer] -> Q [Word8] 69 | mkWord16LE [] = return [] 70 | mkWord16LE (i:is) = do 71 | when (i<0 || i > 0xFFFF) $ 72 | reportError $ "integer " ++ show i ++ " is out of word16 range in literal:" ++ str 73 | ws <- mkWord16LE is 74 | let w1 = fromIntegral (i .&. 0xFF) 75 | w2 = fromIntegral (i `shiftR` 8 .&. 0xFF) 76 | return (fromIntegral w1:w2:ws) 77 | 78 | aW16 :: QuasiQuoter 79 | aW16 = QuasiQuoter 80 | (word16LiteralLE $ \ len addr -> [| word16ArrayFromAddr len $(addr) |]) 81 | (error "Cannot use aW16 as a pattern") 82 | (error "Cannot use aW16 as a type") 83 | (error "Cannot use aW16 as a dec") 84 | 85 | word16ArrayFromAddr :: Int -> Addr# -> PrimArray Word16 86 | word16ArrayFromAddr l addr# = unsafeDupablePerformIO $ do 87 | mba <- newArr l 88 | go l (Ptr addr#) mba 0 89 | unsafeFreezePrimArray mba :: IO (PrimArray Word16) 90 | where 91 | go l ptr mba idx = do 92 | #ifdef WORDS_BIGENDIAN 93 | when (idx < l) $ do 94 | w1 <- peekElemOff ptr (idx*2) :: IO Word8 95 | w2 <- peekElemOff ptr (idx*2+1) :: IO Word8 96 | writePrimArray mba idx (fromIntegral w2 `shiftL` 8 .|. fromIntegral w1 :: Word16) 97 | go l ptr mba (idx+1) 98 | #else 99 | copyMutablePrimArrayFromPtr mba 0 ptr l 100 | #endif 101 | {-# NOINLINE word16ArrayFromAddr #-} -- don't dump every literal with this code 102 | 103 | word32LiteralLE :: (Int -> ExpQ -> ExpQ) -> String -> ExpQ 104 | word32LiteralLE k str = vectorLiteral mkWord32LE k str 105 | where 106 | mkWord32LE :: [Integer] -> Q [Word8] 107 | mkWord32LE [] = return [] 108 | mkWord32LE (i:is) = do 109 | when (i<0 || i > 0xFFFFFFFF) $ 110 | reportError $ "integer " ++ show i ++ " is out of word32 range in literal:" ++ str 111 | ws <- mkWord32LE is 112 | let w1 = fromIntegral (i .&. 0xFF) 113 | w2 = fromIntegral (i `shiftR` 8 .&. 0xFF) 114 | w3 = fromIntegral (i `shiftR` 16 .&. 0xFF) 115 | w4 = fromIntegral (i `shiftR` 24 .&. 0xFF) 116 | return (fromIntegral w1:w2:w3:w4:ws) 117 | 118 | aW32 :: QuasiQuoter 119 | aW32 = QuasiQuoter 120 | (word32LiteralLE $ \ len addr -> [| word32ArrayFromAddr len $(addr) |]) 121 | (error "Cannot use aW32 as a pattern") 122 | (error "Cannot use aW32 as a type") 123 | (error "Cannot use aW32 as a dec") 124 | 125 | word32ArrayFromAddr :: Int -> Addr# -> PrimArray Word32 126 | word32ArrayFromAddr l addr# = unsafeDupablePerformIO $ do 127 | mba <- newArr l 128 | go l (Ptr addr#) mba 0 129 | unsafeFreezePrimArray mba :: IO (PrimArray Word32) 130 | where 131 | go l ptr mba !idx = do 132 | #ifdef WORDS_BIGENDIAN 133 | when (idx < l) $ do 134 | w1 <- peekElemOff ptr (idx*4) :: IO Word8 135 | w2 <- peekElemOff ptr (idx*4+1) :: IO Word8 136 | w3 <- peekElemOff ptr (idx*4+2) :: IO Word8 137 | w4 <- peekElemOff ptr (idx*4+3) :: IO Word8 138 | writePrimArray mba idx (fromIntegral w4 `shiftL` 24 139 | .|. fromIntegral w3 `shiftL` 16 140 | .|. fromIntegral w2 `shiftL` 8 141 | .|. fromIntegral w1 :: Word32) 142 | go l ptr mba (idx+1) 143 | #else 144 | copyMutablePrimArrayFromPtr mba 0 ptr l -- alright, we don't support mix endianess 145 | #endif 146 | {-# NOINLINE word32ArrayFromAddr #-} 147 | -------------------------------------------------------------------------------- /Data/Textual.hs: -------------------------------------------------------------------------------- 1 | module Data.Builder.Textual where 2 | 3 | class Textual a where 4 | textual :: a -> Builder 5 | 6 | class Textual a => FormatTexutal a where 7 | data Format a 8 | format :: Format a -> a -> Builder 9 | 10 | 11 | 12 | -------------------------------------------------------------------------------- 13 | 14 | class ParseTextual a where 15 | parseTextual :: Parser a 16 | -------------------------------------------------------------------------------- /GHC/Stack/Compat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE ImplicitParams #-} 5 | 6 | module GHC.Stack.Compat 7 | ( -- Compatible layer of GHC.Stack 8 | HasCallStack 9 | , CallStack 10 | , callStack 11 | , prettyCallStack 12 | ) where 13 | 14 | import GHC.Stack 15 | 16 | #if !MIN_VERSION_base(4,9,0) 17 | type HasCallStack = (?callStack :: CallStack) 18 | 19 | callStack :: HasCallStack => CallStack 20 | {-# INLINE callStack #-} 21 | callStack = ?callStack 22 | 23 | prettyCallStack :: CallStack -> String 24 | prettyCallStack = showCallStack 25 | #endif 26 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, winter 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of winter nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Haskell stdio: haskell standard input and output 2 | ================================================ 3 | 4 | [![Linux Build Status](https://img.shields.io/travis/winterland1989/stdio/master.svg?label=Linux%20build)](https://travis-ci.org/winterland1989/stdio) 5 | [![Windows Build Status](https://img.shields.io/appveyor/ci/winterland1989/stdio/master.svg?label=Windows%20build)](https://ci.appveyor.com/project/winterland1989/stdio/branch/master) 6 | 7 | Notice 8 | ------ 9 | 10 | Please head to the [official repo](https://github.com/haskell-stdio/stdio). This is the historical experimental repo of stdio, which records many interesting ideas and exploration, and some of these ideas may get revived if needed. Notable branches: 11 | 12 | + `fix_accept3`, this is the final choosen branch for offical repo based on performance. 13 | 14 | + `hs_try_putmvar`, this branch uses the `hs_try_putmvar`(present since GHC 8.2) RTS function to unblock thread. Currently it's slow due to global stable pointer table's lock, and the table always need to be scanned even in minor GC. And my benchmark seems to indicate the malloc/free overhead of `PutMVar` struct is quite large. 15 | 16 | + `strlen-slot-allocator`, this branch uses a least-unused-integer allocator based on a 0-1 slot buffer and C `strlen` function. This allocator saves little memory compare to current linked-list solution, thus we choose the later. 17 | 18 | + `stm-wake-up`, this branch uses `STM` to notify threads which are blocked on waiting uv manager thread to wake up. Under high workload `STM` 's overhead is just too much. 19 | 20 | + `fix_acceptX`, these branches record various ideas on doing socket/pipe accepting, and some of them contain bugs, which are fixed in `fix_accept3`. 21 | 22 | + `new_errno`, this branch tried to unify errno handling with typeclass `IOReturn`. While nice and haskellish as it seems, a more pratical approach is choosen later based on libuv's `uv_translate_sys_error`. and this branch leads to the discovery of a [ghc bug](https://ghc.haskell.org/trac/ghc/ticket/14125) (you can get the basic idea from the trac's issue code). 23 | 24 | Most of the other branches are early experiments which are buggy and incomplete, they served to give approximately performance data. Luckily though i got many detail things wrong, but i didn't miss the large elephant: libuv is definitely up to the task. 25 | 26 | User Guide 27 | ---------- 28 | 29 | On windows we have bundled libuv source, so not extra steps to be taken. 30 | 31 | On \*nix platforms, you should install libuv library first, you can use your distribution's package manager if available, for example: 32 | 33 | ``` 34 | # on debian/ubuntu, make sure to use 1.x 35 | apt-get install libuv1-dev libuv1 36 | 37 | # on MacOS, we recommend brew 38 | brew install libuv 39 | 40 | ... 41 | ``` 42 | 43 | You can also build libuv from source following the guide [here](https://github.com/libuv/libuv#build-instructions), and modify your `LIBRARY_PATH/CPATH` if necessary. After libuv is in place, installing stdio is as easy as any other haskell packages. 44 | 45 | ``` 46 | cabal install stdio 47 | ``` 48 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMainWithHooks autoconfUserHooks 3 | -------------------------------------------------------------------------------- /System/IO/FileSystem.hs: -------------------------------------------------------------------------------- 1 | module System.IO.FileSystem where 2 | 3 | import System.IO.Exception 4 | import System.IO.UV.Internal 5 | import System.IO.UV.Exception 6 | import Foreign.Ptr 7 | import Foreign.C 8 | import Data.CBytes 9 | 10 | scandir :: CBytes -> IO [(CBytes, UVDirEntType)] 11 | scandir path = withCBytes path $ \ p -> 12 | withResource (initUVReq uV_FS) $ \ req -> do 13 | uvFSScandir nullPtr req p False 14 | go req 15 | where 16 | go req = do 17 | withResource initUVDirEnt $ \ ent -> do 18 | r <- uv_fs_scandir_next req ent 19 | if r == uV_EOF 20 | then return [] 21 | else if r < 0 22 | then do 23 | throwUVIfMinus_ $ return r 24 | return [] 25 | else do 26 | (path, typ) <- peekUVDirEnt ent 27 | path' <- fromCString path 28 | rest <- go req 29 | return ((path', typ) : rest) 30 | 31 | 32 | -------------------------------------------------------------------------------- /System/IO/FileSystem/Slow.hs: -------------------------------------------------------------------------------- 1 | module System.IO.FileSystem.Slow where 2 | 3 | import System.IO.Exception 4 | import System.IO.UV.Internal 5 | import System.IO.UV.Manager 6 | import System.IO.UV.Exception 7 | import Control.Concurrent.MVar 8 | import Foreign.Ptr 9 | import Foreign.C 10 | import Data.CBytes 11 | 12 | scandir :: CBytes -> IO [(CBytes, UVDirEntType)] 13 | scandir path = do 14 | uvm <- getUVManager 15 | withCBytes path $ \ p -> 16 | withResource (initUVSlot uvm) $ \ slot -> 17 | withResource (initUVReq uV_FS) $ \ req -> do 18 | lock <- getBlockMVar uvm slot 19 | pokeUVReqData req slot 20 | withUVManager uvm $ \ loop -> uvFSScandir loop req p True 21 | takeMVar lock 22 | go req 23 | where 24 | go req = do 25 | withResource initUVDirEnt $ \ ent -> do 26 | r <- uv_fs_scandir_next req ent 27 | if r == uV_EOF 28 | then return [] 29 | else if r < 0 30 | then do 31 | throwUVIfMinus_ $ return r 32 | return [] 33 | else do 34 | (path, typ) <- peekUVDirEnt ent 35 | path' <- fromCString path 36 | rest <- go req 37 | return ((path', typ) : rest) 38 | 39 | 40 | 41 | -------------------------------------------------------------------------------- /System/IO/Log.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | 3 | module System.IO.Log where 4 | 5 | newtype Logger = forall o. Output o => Logger 6 | { loggerOutput :: MVar (BufferedOutput o) 7 | , loggerPrefix :: Bytes -> IO Builder 8 | , loggerNoDebug :: Bool 9 | , loggerAutoFlush :: Bool 10 | } 11 | 12 | newLogger :: Output o => o -> Int -> Bool -> IO Logger 13 | 14 | 15 | changeDefaultLogger :: Logger -> IO () 16 | 17 | getDefaultLogger :: IO Logger 18 | 19 | -------------------------------------------------------------------------------- 20 | 21 | defaultLogger :: IORef Logger 22 | 23 | debug :: Text -> IO () 24 | 25 | info :: Text -> IO () 26 | 27 | warn :: Text -> IO () 28 | 29 | fatal :: Text -> IO () 30 | 31 | debug_ :: Logger -> Text -> IO () 32 | 33 | info_ :: Logger -> Text -> IO () 34 | 35 | warn_ :: Logger -> Text -> IO () 36 | 37 | fatal_ :: Logger -> Text -> IO () 38 | 39 | -------------------------------------------------------------------------------- /System/IO/Net.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE ExistentialQuantification #-} 6 | 7 | {-| 8 | Module : System.IO.Net 9 | Description : TCP or IPC servers and clients 10 | Copyright : (c) Winterland, 2018 11 | License : BSD 12 | Maintainer : drkoster@qq.com 13 | Stability : experimental 14 | Portability : non-portable 15 | 16 | This module provides an API for creating TCP or IPC servers and clients. IPC Support is implemented with named pipes on Windows, and UNIX domain sockets on other operating systems. 17 | 18 | On UNIX, the local domain is also known as the UNIX domain. The path is a filesystem path name. It gets truncated to sizeof(sockaddr_un.sun_path) - 1, which varies on different operating system between 91 and 107 bytes. The typical values are 107 on Linux and 103 on macOS. The path is subject to the same naming conventions and permissions checks as would be done on file creation. It will be visible in the filesystem, and will persist until unlinked. 19 | 20 | On Windows, the local domain is implemented using a named pipe. The path must refer to an entry in \\?\pipe\ or \\.\pipe\. Any characters are permitted, but the latter may do some processing of pipe names, such as resolving .. sequences. Despite appearances, the pipe name space is flat. Pipes will not persist, they are removed when the last reference to them is closed. Do not forget JavaScript string escaping requires paths to be specified with double-backslashes, such as: 21 | 22 | net.createServer().listen( 23 | path.join('\\\\?\\pipe', process.cwd(), 'myctl')); 24 | 25 | -} 26 | 27 | module System.IO.Net ( 28 | initTCPConnection 29 | , ServerConfig(..) 30 | , defaultServerConfig 31 | , startServer 32 | , module System.IO.Net.SockAddr 33 | ) where 34 | 35 | 36 | import System.IO.Net.SockAddr 37 | import System.IO.Exception 38 | import System.IO.Buffered 39 | import System.IO.UV.Manager 40 | import System.IO.UV.Stream 41 | import System.IO.UV.Internal 42 | import Control.Concurrent.MVar 43 | import Foreign.Ptr 44 | import GHC.Ptr 45 | import Foreign.C.Types (CInt(..)) 46 | import Data.Int 47 | import Data.Vector 48 | import Data.IORef.Unboxed 49 | import Control.Concurrent 50 | import Control.Concurrent.MVar 51 | import Control.Monad 52 | import Control.Monad.IO.Class 53 | import Control.Monad.Primitive 54 | import Data.Primitive.PrimArray 55 | import Foreign.PrimArray 56 | 57 | 58 | initTCPConnection :: HasCallStack 59 | => SockAddr 60 | -> Maybe SockAddr 61 | -> Resource UVStream 62 | initTCPConnection target local = do 63 | conn <- initTCPStream 64 | let uvm = uvsManager conn 65 | handle = uvsHandle conn 66 | connSlot <- initUVSlot uvm 67 | connReq <- initUVReq uV_CONNECT 68 | liftIO $ do 69 | forM_ local $ \ local' -> withSockAddr local' $ \ localPtr -> 70 | uvTCPBind handle localPtr False 71 | 72 | withSockAddr target $ \ target' -> do 73 | m <- getBlockMVar uvm connSlot 74 | tryTakeMVar m 75 | pokeUVReqData connReq connSlot 76 | withUVManager' uvm $ uvTCPConnect connReq handle target' 77 | takeMVar m 78 | throwUVIfMinus_ $ peekBufferTable uvm connSlot 79 | return conn 80 | 81 | -- | A TCP/Pipe server configuration 82 | -- 83 | data ServerConfig = forall e. Exception e => ServerConfig 84 | { serverAddr :: SockAddr 85 | , serverBackLog :: Int 86 | , serverWorker :: UVStream -> IO () 87 | , serverWorkerNoDelay :: Bool 88 | , serverWorkerHandler :: e -> IO () 89 | } 90 | 91 | -- | A default hello world server on localhost:8888 92 | -- 93 | -- Test it with @main = startServer defaultServerConfig@, now try @nc -v 127.0.0.1 8888@ 94 | -- 95 | defaultServerConfig :: ServerConfig 96 | defaultServerConfig = ServerConfig 97 | (SockAddrInet 8888 inetAny) 98 | 128 99 | (\ uvs -> writeOutput uvs (Ptr "hello world"#) 11) 100 | True 101 | (print :: SomeException -> IO()) 102 | 103 | -- | Start a server 104 | -- 105 | -- Fork new worker thread upon a new connection. 106 | -- 107 | startServer :: ServerConfig -> IO () 108 | startServer ServerConfig{..} = 109 | withResource initTCPStream $ \ server -> do 110 | 111 | let serverHandle = uvsHandle server 112 | serverManager = uvsManager server 113 | serverSlot = uvsReadSlot server 114 | 115 | withResource (initUVHandle uV_CHECK 116 | (\ loop handle -> hs_uv_accept_check_init loop handle serverHandle >> return handle) serverManager) $ \ _ -> 117 | withSockAddr serverAddr $ \ addrPtr -> do 118 | 119 | 120 | m <- getBlockMVar serverManager serverSlot 121 | acceptBuf <- newPinnedPrimArray serverBackLog 122 | 123 | let acceptBufPtr = (coerce (mutablePrimArrayContents acceptBuf :: Ptr UVFD)) 124 | tryTakeMVar m 125 | 126 | withUVManager' serverManager $ do 127 | uvTCPBind serverHandle addrPtr False 128 | pokeBufferTable serverManager serverSlot acceptBufPtr (-serverBackLog) 129 | tryTakeMVar m 130 | uvListen serverHandle (fromIntegral serverBackLog) 131 | 132 | forever $ do 133 | takeMVar m 134 | 135 | -- we lock uv manager here in case of next uv_run overwrite current accept buffer 136 | acceptBufCopy <- withUVManager' serverManager $ do 137 | acceptedOffset <- peekBufferTable serverManager serverSlot 138 | let acceptedOffset' = if acceptedOffset > 0 then acceptedOffset else serverBackLog 139 | 140 | -- We use the sign bit to indicate c side we can begin accepting fresh 141 | -- this sign bit will be removed if we successfully accept fds during uv_run 142 | pokeBufferTable serverManager serverSlot acceptBufPtr (-serverBackLog) 143 | -- It's important we clear this lock before hand over uv mananger 144 | tryTakeMVar m 145 | 146 | let acceptedNum = serverBackLog - acceptedOffset' 147 | acceptBuf' <- newPrimArray acceptedNum 148 | copyMutablePrimArray acceptBuf' 0 acceptBuf acceptedOffset' acceptedNum 149 | unsafeFreezePrimArray acceptBuf' 150 | 151 | let accepted = sizeofPrimArray acceptBufCopy 152 | 153 | forM_ [0..accepted-1] $ \ i -> do 154 | let fd = indexPrimArray acceptBufCopy i 155 | if fd < 0 156 | then throwUVIfMinus_ (return fd) -- minus fd indicate a server error and we should close server 157 | else do 158 | void . forkBa . withResource initTCPStream $ \ client -> do 159 | handle serverWorkerHandler $ do 160 | withUVManager' (uvsManager client) $ do 161 | uvTCPOpen (uvsHandle client) (fromIntegral fd) 162 | when serverWorkerNoDelay $ 163 | uvTCPNodelay (uvsHandle client) True 164 | serverWorker client 165 | 166 | -------------------------------------------------------------------------------- 167 | 168 | uvListen :: HasCallStack => Ptr UVHandle -> CInt -> IO () 169 | uvListen handle backlog = throwUVIfMinus_ (hs_uv_listen handle backlog) 170 | foreign import ccall unsafe hs_uv_listen :: Ptr UVHandle -> CInt -> IO CInt 171 | 172 | foreign import ccall unsafe hs_uv_listen_resume :: Ptr UVHandle -> IO () 173 | 174 | foreign import ccall unsafe hs_uv_accept_check_init :: Ptr UVLoop -> Ptr UVHandle -> Ptr UVHandle -> IO CInt 175 | 176 | foreign import ccall unsafe "hs_uv_listen_resume" uvListenResume :: Ptr UVHandle -> IO () 177 | -------------------------------------------------------------------------------- /System/IO/TTY.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE ExistentialQuantification #-} 6 | 7 | {-| 8 | Module : System.IO.TTY 9 | Description : TCP or IPC servers and clients 10 | Copyright : (c) Winterland, 2018 11 | License : BSD 12 | Maintainer : drkoster@qq.com 13 | Stability : experimental 14 | Portability : non-portable 15 | 16 | This module provides an API for opening tty as 'UVStream'. In most case, it will not be necessary to use this module directly 17 | 18 | -} 19 | 20 | module System.IO.TTY( 21 | UVStream 22 | , stdin 23 | , stdout 24 | , stderr 25 | ) where 26 | 27 | import System.IO.UV.Stream 28 | import System.IO.Exception 29 | import System.IO.Unsafe 30 | 31 | stdin :: UVStream 32 | {-# NOINLINE stdin #-} 33 | stdin = unsafePerformIO $ do 34 | (stdin, _ ) <- acquire (initTTYStream 0) -- well, stdin live across whole program 35 | return stdin -- so we give up resource management 36 | 37 | stdout :: UVStream 38 | {-# NOINLINE stdout #-} 39 | stdout = unsafePerformIO $ do 40 | (stdin, _ ) <- acquire (initTTYStream 1) 41 | return stdin 42 | 43 | stderr :: UVStream 44 | {-# NOINLINE stderr #-} 45 | stderr = unsafePerformIO $ do 46 | (stdin, _ ) <- acquire (initTTYStream 2) 47 | return stdin 48 | -------------------------------------------------------------------------------- /System/IO/UV/Exception.hsc: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : System.IO.UV.Exception 3 | Description : Extensible IO exceptions 4 | Copyright : (c) Winterland, 2017 5 | License : BSD 6 | Maintainer : drkoster@qq.com 7 | Stability : experimental 8 | Portability : non-portable 9 | 10 | 11 | -} 12 | 13 | module System.IO.UV.Exception where 14 | 15 | import Foreign.C.Types 16 | import Foreign.C.String 17 | 18 | #include "uv.h" 19 | #include "hs_uv.h" 20 | 21 | -- Exception related 22 | 23 | uvStdError :: CInt -> IO String 24 | uvStdError errno = peekCString =<< uv_strerror errno 25 | 26 | foreign import ccall unsafe uv_strerror :: CInt -> IO CString 27 | 28 | uvErrName :: CInt -> IO String 29 | uvErrName errno = peekCString =<< uv_err_name errno 30 | 31 | foreign import ccall unsafe uv_err_name :: CInt -> IO CString 32 | 33 | -- | argument list too long 34 | #{enum CInt, CInt, uV_E2BIG = UV_E2BIG } 35 | -- | permission denied 36 | #{enum CInt, CInt, uV_EACCES = UV_EACCES } 37 | -- | address already in use 38 | #{enum CInt, CInt, uV_EADDRINUSE = UV_EADDRINUSE } 39 | -- | address not available 40 | #{enum CInt, CInt, uV_EADDRNOTAVAIL = UV_EADDRNOTAVAIL } 41 | -- | address family not supported 42 | #{enum CInt, CInt, uV_EAFNOSUPPORT = UV_EAFNOSUPPORT } 43 | -- | resource temporarily unavailable 44 | #{enum CInt, CInt, uV_EAGAIN = UV_EAGAIN } 45 | -- | address family not supported 46 | #{enum CInt, CInt, uV_EAI_ADDRFAMILY = UV_EAI_ADDRFAMILY } 47 | -- | temporary failure 48 | #{enum CInt, CInt, uV_EAI_AGAIN = UV_EAI_AGAIN } 49 | -- | bad ai_flags value 50 | #{enum CInt, CInt, uV_EAI_BADFLAGS = UV_EAI_BADFLAGS } 51 | -- | invalid value for hints 52 | #{enum CInt, CInt, uV_EAI_BADHINTS = UV_EAI_BADHINTS } 53 | -- | request canceled 54 | #{enum CInt, CInt, uV_EAI_CANCELED = UV_EAI_CANCELED } 55 | -- | permanent failure 56 | #{enum CInt, CInt, uV_EAI_FAIL = UV_EAI_FAIL } 57 | -- | ai_family not supported 58 | #{enum CInt, CInt, uV_EAI_FAMILY = UV_EAI_FAMILY } 59 | -- | out of memory 60 | #{enum CInt, CInt, uV_EAI_MEMORY = UV_EAI_MEMORY } 61 | -- | no address 62 | #{enum CInt, CInt, uV_EAI_NODATA = UV_EAI_NODATA } 63 | -- | unknown node or service 64 | #{enum CInt, CInt, uV_EAI_NONAME = UV_EAI_NONAME } 65 | -- | argument buffer overflow 66 | #{enum CInt, CInt, uV_EAI_OVERFLOW = UV_EAI_OVERFLOW } 67 | -- | resolved protocol is unknown 68 | #{enum CInt, CInt, uV_EAI_PROTOCOL = UV_EAI_PROTOCOL } 69 | -- | service not available for socket type 70 | #{enum CInt, CInt, uV_EAI_SERVICE = UV_EAI_SERVICE } 71 | -- | socket type not supported 72 | #{enum CInt, CInt, uV_EAI_SOCKTYPE = UV_EAI_SOCKTYPE } 73 | -- | connection already in progress 74 | #{enum CInt, CInt, uV_EALREADY = UV_EALREADY } 75 | -- | bad file descriptor 76 | #{enum CInt, CInt, uV_EBADF = UV_EBADF } 77 | -- | resource busy or locked 78 | #{enum CInt, CInt, uV_EBUSY = UV_EBUSY } 79 | -- | operation canceled 80 | #{enum CInt, CInt, uV_ECANCELED = UV_ECANCELED } 81 | -- | invalid Unicode character 82 | #{enum CInt, CInt, uV_ECHARSET = UV_ECHARSET } 83 | -- | software caused connection abort 84 | #{enum CInt, CInt, uV_ECONNABORTED = UV_ECONNABORTED } 85 | -- | connection refused 86 | #{enum CInt, CInt, uV_ECONNREFUSED = UV_ECONNREFUSED } 87 | -- | connection reset by peer 88 | #{enum CInt, CInt, uV_ECONNRESET = UV_ECONNRESET } 89 | -- | destination address required 90 | #{enum CInt, CInt, uV_EDESTADDRREQ = UV_EDESTADDRREQ } 91 | -- | file already exists 92 | #{enum CInt, CInt, uV_EEXIST = UV_EEXIST } 93 | -- | bad address in system call argument 94 | #{enum CInt, CInt, uV_EFAULT = UV_EFAULT } 95 | -- | file too large 96 | #{enum CInt, CInt, uV_EFBIG = UV_EFBIG } 97 | -- | host is unreachable 98 | #{enum CInt, CInt, uV_EHOSTUNREACH = UV_EHOSTUNREACH } 99 | -- | interrupted system call 100 | #{enum CInt, CInt, uV_EINTR = UV_EINTR } 101 | -- | invalid argument 102 | #{enum CInt, CInt, uV_EINVAL = UV_EINVAL } 103 | -- | i/o error 104 | #{enum CInt, CInt, uV_EIO = UV_EIO } 105 | -- | socket is already connected 106 | #{enum CInt, CInt, uV_EISCONN = UV_EISCONN } 107 | -- | illegal operation on a directory 108 | #{enum CInt, CInt, uV_EISDIR = UV_EISDIR } 109 | -- | too many symbolic links encountered 110 | #{enum CInt, CInt, uV_ELOOP = UV_ELOOP } 111 | -- | too many open files 112 | #{enum CInt, CInt, uV_EMFILE = UV_EMFILE } 113 | -- | message too long 114 | #{enum CInt, CInt, uV_EMSGSIZE = UV_EMSGSIZE } 115 | -- | name too long 116 | #{enum CInt, CInt, uV_ENAMETOOLONG = UV_ENAMETOOLONG } 117 | -- | network is down 118 | #{enum CInt, CInt, uV_ENETDOWN = UV_ENETDOWN } 119 | -- | network is unreachable 120 | #{enum CInt, CInt, uV_ENETUNREACH = UV_ENETUNREACH } 121 | -- | file table overflow 122 | #{enum CInt, CInt, uV_ENFILE = UV_ENFILE } 123 | -- | no buffer space available 124 | #{enum CInt, CInt, uV_ENOBUFS = UV_ENOBUFS } 125 | -- | no such device 126 | #{enum CInt, CInt, uV_ENODEV = UV_ENODEV } 127 | -- | no such file or directory 128 | #{enum CInt, CInt, uV_ENOENT = UV_ENOENT } 129 | -- | not enough memory 130 | #{enum CInt, CInt, uV_ENOMEM = UV_ENOMEM } 131 | -- | machine is not on the network 132 | #{enum CInt, CInt, uV_ENONET = UV_ENONET } 133 | -- | protocol not available 134 | #{enum CInt, CInt, uV_ENOPROTOOPT = UV_ENOPROTOOPT } 135 | -- | no space left on device 136 | #{enum CInt, CInt, uV_ENOSPC = UV_ENOSPC } 137 | -- | function not implemented 138 | #{enum CInt, CInt, uV_ENOSYS = UV_ENOSYS } 139 | -- | socket is not connected 140 | #{enum CInt, CInt, uV_ENOTCONN = UV_ENOTCONN } 141 | -- | not a directory 142 | #{enum CInt, CInt, uV_ENOTDIR = UV_ENOTDIR } 143 | -- | directory not empty 144 | #{enum CInt, CInt, uV_ENOTEMPTY = UV_ENOTEMPTY } 145 | -- | socket operation on non-socket 146 | #{enum CInt, CInt, uV_ENOTSOCK = UV_ENOTSOCK } 147 | -- | operation not supported on socket 148 | #{enum CInt, CInt, uV_ENOTSUP = UV_ENOTSUP } 149 | -- | operation not permitted 150 | #{enum CInt, CInt, uV_EPERM = UV_EPERM } 151 | -- | broken pipe 152 | #{enum CInt, CInt, uV_EPIPE = UV_EPIPE } 153 | -- | protocol error 154 | #{enum CInt, CInt, uV_EPROTO = UV_EPROTO } 155 | -- | protocol not supported 156 | #{enum CInt, CInt, uV_EPROTONOSUPPORT= UV_EPROTONOSUPPORT} 157 | -- | protocol wrong type for socket 158 | #{enum CInt, CInt, uV_EPROTOTYPE = UV_EPROTOTYPE } 159 | -- | result too large 160 | #{enum CInt, CInt, uV_ERANGE = UV_ERANGE } 161 | -- | read-only file system 162 | #{enum CInt, CInt, uV_EROFS = UV_EROFS } 163 | -- | cannot send after transport endpoint shutdown 164 | #{enum CInt, CInt, uV_ESHUTDOWN = UV_ESHUTDOWN } 165 | -- | invalid seek 166 | #{enum CInt, CInt, uV_ESPIPE = UV_ESPIPE } 167 | -- | no such process 168 | #{enum CInt, CInt, uV_ESRCH = UV_ESRCH } 169 | -- | connection timed out 170 | #{enum CInt, CInt, uV_ETIMEDOUT = UV_ETIMEDOUT } 171 | -- | text file is busy 172 | #{enum CInt, CInt, uV_ETXTBSY = UV_ETXTBSY } 173 | -- | cross-device link not permitted 174 | #{enum CInt, CInt, uV_EXDEV = UV_EXDEV } 175 | -- | unknown error 176 | #{enum CInt, CInt, uV_UNKNOWN = UV_UNKNOWN } 177 | -- | end of file 178 | #{enum CInt, CInt, uV_EOF = UV_EOF } 179 | -- | no such device or address 180 | #{enum CInt, CInt, uV_ENXIO = UV_ENXIO } 181 | -- | too many links 182 | #{enum CInt, CInt, uV_EMLINK = UV_EMLINK } 183 | -------------------------------------------------------------------------------- /System/IO/UV/Stream.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | 3 | module System.IO.UV.Stream where 4 | 5 | import System.IO.UV.Manager 6 | import System.IO.Exception 7 | import System.IO.UV.Exception (uV_EOF) 8 | import System.IO.Buffered 9 | import System.IO.UV.Internal 10 | import Foreign.Ptr 11 | import Foreign.C.Types 12 | import Data.Word 13 | import Control.Concurrent.MVar 14 | import Control.Monad.IO.Class 15 | 16 | -- | A higher level wrappe for uv_stream_t 17 | -- 18 | -- 19 | data UVStream = UVStream 20 | { uvsHandle :: {-# UNPACK #-} !(Ptr UVHandle) 21 | , uvsReadSlot :: {-# UNPACK #-} !UVSlot 22 | , uvsWriteReq :: {-# UNPACK #-} !(Ptr UVReq) 23 | , uvsWriteSlot :: {-# UNPACK #-} !UVSlot 24 | , uvsManager :: UVManager 25 | } 26 | 27 | initUVStream :: HasCallStack => (UVManager -> Resource (Ptr UVHandle)) -> Resource UVStream 28 | initUVStream handleRes = do 29 | uvm <- liftIO getUVManager 30 | rslot <- initUVSlot uvm 31 | wslot <- initUVSlot uvm 32 | handle <- handleRes uvm 33 | req <- initUVReq uV_WRITE 34 | liftIO $ do 35 | pokeUVHandleData handle rslot 36 | pokeUVReqData req wslot 37 | return (UVStream handle rslot req wslot uvm) 38 | 39 | initTCPStream :: HasCallStack => Resource UVStream 40 | initTCPStream = initUVStream $ 41 | initUVHandle uV_TCP (\ loop handle -> uvTCPInit loop handle >> return handle) 42 | 43 | initPipeStream :: HasCallStack => Resource UVStream 44 | initPipeStream = initUVStream $ 45 | initUVHandle uV_NAMED_PIPE (\ loop handle -> uvPipeInit loop handle >> return handle) 46 | 47 | initTTYStream :: HasCallStack => UVFD -> Resource UVStream 48 | initTTYStream fd = initUVStream $ 49 | initUVHandle uV_TTY (\ loop handle -> uvTTYInit loop handle fd >> return handle) 50 | 51 | instance Input UVStream where 52 | -- readInput :: HasCallStack => UVStream -> Ptr Word8 -> Int -> IO Int 53 | readInput uvs@(UVStream handle rslot _ _ uvm) buf len = do 54 | m <- getBlockMVar uvm rslot 55 | tryTakeMVar m 56 | withUVManager' uvm $ do 57 | pokeBufferTable uvm rslot buf len 58 | uvReadStart handle 59 | takeMVar m 60 | r <- peekBufferTable uvm rslot 61 | if | r > 0 -> return r 62 | -- r == 0 should be impossible, since we guard this situation in c side, but we handle it anyway 63 | -- nread might be 0, which does not indicate an error or EOF. This is equivalent to EAGAIN or EWOULDBLOCK under read(2) 64 | | r == fromIntegral uV_EOF -> return 0 65 | | r < 0 -> throwUVIfMinus (return r) 66 | 67 | uvReadStart :: Ptr UVHandle -> IO () 68 | uvReadStart = throwUVIfMinus_ . hs_uv_read_start 69 | foreign import ccall unsafe hs_uv_read_start :: Ptr UVHandle -> IO CInt 70 | 71 | instance Output UVStream where 72 | -- writeOutput :: HasCallStack => UVStream -> Ptr Word8 -> Int -> IO () 73 | writeOutput (UVStream handle _ req wslot uvm) buf len = do 74 | m <- getBlockMVar uvm wslot 75 | tryTakeMVar m 76 | withUVManager' uvm $ do 77 | pokeBufferTable uvm wslot buf len 78 | uvWrite req handle 79 | takeMVar m 80 | throwUVIfMinus_ $ peekBufferTable uvm wslot 81 | 82 | uvWrite :: Ptr UVReq -> Ptr UVHandle -> IO () 83 | uvWrite req handle = throwUVIfMinus_ $ hs_uv_write req handle 84 | foreign import ccall unsafe hs_uv_write :: Ptr UVReq -> Ptr UVHandle -> IO CInt 85 | 86 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | install: 2 | # Using '-y' and 'refreshenv' as a workaround to: 3 | # https://github.com/haskell/cabal/issues/3687 4 | - choco install -y ghc --version 8.0.2 5 | - refreshenv 6 | # See http://help.appveyor.com/discussions/problems/6312-curl-command-not-found#comment_42195491 7 | # NB: Do this after refreshenv, otherwise it will be clobbered! 8 | - set PATH=C:\Program Files\Git\mingw64\bin;%PATH% 9 | # TODO: remove --insecure, this is to workaround haskell.org 10 | # failing to send intermediate cert; see https://github.com/haskell/cabal/pull/4172 11 | - curl -o cabal.zip --insecure --progress-bar https://www.haskell.org/cabal/release/cabal-install-1.24.0.0/cabal-install-1.24.0.0-x86_64-unknown-mingw32.zip 12 | - 7z x -bd cabal.zip 13 | - cabal --version 14 | - cabal update 15 | - refreshenv 16 | 17 | build_script: 18 | - git submodule update --init 19 | - cabal install Cabal 20 | - cabal install --only-dependencies --enable-tests --enable-benchmarks 21 | - cabal configure --enable-tests --enable-benchmarks 22 | - cabal build # this builds all libraries and executables (including tests/benchmarks) 23 | - cabal test 24 | # - cabal check 25 | - cabal sdist # tests that a source-distribution can be generated 26 | -------------------------------------------------------------------------------- /bench/BitTwiddle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE PackageImports #-} 4 | {-# LANGUAGE MagicHash #-} 5 | 6 | module BitTwiddle (bitTwiddle) where 7 | 8 | import Criterion.Main 9 | import qualified Data.ByteString as BS 10 | import qualified "stdio" Data.Vector as V 11 | import Control.DeepSeq 12 | import Control.Monad 13 | import Data.Word 14 | import GHC.Prim 15 | import GHC.Types 16 | import Data.Primitive.ByteArray 17 | import Data.Primitive.PrimArray 18 | import qualified Data.Primitive.BitTwiddle as T 19 | import qualified Data.List as List 20 | 21 | bytestring1000000 :: BS.ByteString 22 | bytestring1000000 = BS.replicate 1000000 0 23 | 24 | bytes1000000 :: V.Bytes 25 | bytes1000000 = V.replicate 1000000 0 26 | 27 | 28 | bitTwiddle :: [Benchmark] 29 | bitTwiddle = 30 | [ bgroup "memchr 1000000" memchr 31 | , bgroup "memcnt 1000000" memchrReverse 32 | ] 33 | 34 | memchr :: [Benchmark] 35 | memchr = 36 | [ bench "bytestring/elemIndex" $ nf (BS.elemIndex 1) bytestring1000000 37 | , bench "bit-twiddling/memchr" $ nf (\ (V.PrimVector ba s l) -> T.memchr ba 1 s l) bytes1000000 38 | ] 39 | 40 | memchrReverse :: [Benchmark] 41 | memchrReverse = 42 | [ bench "bytestring/elemIndexReverse" $ nf (BS.elemIndexEnd 1) bytestring1000000 43 | , bench "bit-twiddling/memchrReverse" $ nf (\ (V.PrimVector ba s l) -> T.memchrReverse ba 1 s l) bytes1000000 44 | ] 45 | -------------------------------------------------------------------------------- /bench/Builder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE PackageImports #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | module Builder (builder) where 8 | 9 | import Criterion.Main 10 | import qualified Data.ByteString as BS 11 | import qualified Data.ByteString.Builder as BB 12 | import qualified Data.ByteString.Lazy as BL 13 | import qualified Data.Builder as B 14 | import qualified "stdio" Data.Binary as B 15 | import qualified "stdio" Data.Vector as V 16 | import Control.DeepSeq 17 | import Control.Monad 18 | import Control.Exception (evaluate) 19 | import Data.Monoid ((<>)) 20 | import Data.Word 21 | 22 | bytestring1000 :: BS.ByteString 23 | bytestring1000 = BS.replicate 1000 0 24 | 25 | bytes1000 :: V.Bytes 26 | bytes1000 = V.replicate 1000 0 27 | 28 | bytestring20000 :: BS.ByteString 29 | bytestring20000 = BS.replicate 20000 0 30 | 31 | bytes20000 :: V.Bytes 32 | bytes20000 = V.replicate 20000 0 33 | 34 | builder :: [Benchmark] 35 | builder = 36 | [ bgroup "word8 100000000" word8_100000000 37 | , bgroup "word8 10000" word8_10000 38 | , bgroup "word8 32" word8_32 39 | , bgroup "bytestring/bytes 32 * 1000" bytes_32_1000 40 | , bgroup "bytestring/bytes 32 * 20000" bytes_32_20000 41 | ] 42 | 43 | word8_100000000 :: [Benchmark] 44 | word8_100000000 = 45 | [ bench "bytestring/toLazyByteString" $ nf BB.toLazyByteString (mconcat (replicate 100000000 (BB.word8 123))) 46 | , bench "bytestring/toStrict . toLazyByteString" $ nf (BL.toStrict . BB.toLazyByteString) (mconcat (replicate 100000000 (BB.word8 123))) 47 | , bench "stdio/buildBytesList" $ nf B.buildBytesList (mconcat (replicate 100000000 (B.binary @Word8 123))) 48 | , bench "stdio/buildBytes" $ nf B.buildBytes (mconcat (replicate 100000000 (B.binary @Word8 123))) 49 | , bench "stdio/buildAndRun" $ nfIO (B.buildAndRun (void . evaluate) (mconcat (replicate 100000000 (B.binary @Word8 123)))) 50 | ] 51 | 52 | word8_10000 :: [Benchmark] 53 | word8_10000 = 54 | [ bench "bytestring/toLazyByteString" $ nf BB.toLazyByteString (mconcat (replicate 10000 (BB.word8 123))) 55 | , bench "bytestring/toStrict . toLazyByteString" $ nf (BL.toStrict . BB.toLazyByteString) (mconcat (replicate 10000 (BB.word8 123))) 56 | , bench "stdio/buildBytesList" $ nf B.buildBytesList (mconcat (replicate 10000 (B.binary @Word8 123))) 57 | , bench "stdio/buildBytes" $ nf B.buildBytes (mconcat (replicate 10000 (B.binary @Word8 123))) 58 | , bench "stdio/buildAndRun" $ nfIO (B.buildAndRun (void . evaluate) (mconcat (replicate 10000 (B.binary @Word8 123)))) 59 | ] 60 | 61 | word8_32 :: [Benchmark] 62 | word8_32 = 63 | [ bench "bytestring/toLazyByteString" $ nf BB.toLazyByteString (mconcat (replicate 32 (BB.word8 123))) 64 | , bench "bytestring/toStrict . toLazyByteString" $ nf (BL.toStrict . BB.toLazyByteString) (mconcat (replicate 32 (BB.word8 123))) 65 | , bench "stdio/buildBytesList" $ nf B.buildBytesList (mconcat (replicate 32 (B.binary @Word8 123))) 66 | , bench "stdio/buildBytes" $ nf B.buildBytes (mconcat (replicate 32 (B.binary @Word8 123))) 67 | , bench "stdio/buildAndRun" $ nfIO (B.buildAndRun (void . evaluate) (mconcat (replicate 32 (B.binary @Word8 123)))) 68 | ] 69 | 70 | bytes_32_1000 :: [Benchmark] 71 | bytes_32_1000 = 72 | [ bench "bytestring/toLazyByteString" $ nf BB.toLazyByteString 73 | (mconcat (replicate 32 $ BB.byteString bytestring1000)) 74 | , bench "stdio/buildBytesList" $ nf B.buildBytesList (mconcat (replicate 32 (B.binary bytes1000))) 75 | , bench "stdio/buildAndRun" $ nfIO (B.buildAndRun (void . evaluate) (mconcat (replicate 32 (B.binary bytes1000)))) 76 | ] 77 | 78 | bytes_32_20000 :: [Benchmark] 79 | bytes_32_20000 = 80 | [ bench "bytestring/toLazyByteString" $ nf BB.toLazyByteString 81 | (mconcat (replicate 32 $ BB.byteString bytestring20000)) 82 | , bench "stdio/buildBytesList" $ nf B.buildBytesList (mconcat (replicate 32 (B.binary bytes20000))) 83 | , bench "stdio/buildAndRun" $ nfIO (B.buildAndRun (void . evaluate) (mconcat (replicate 32 (B.binary bytes20000)))) 84 | ] 85 | 86 | -------------------------------------------------------------------------------- /bench/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE PackageImports #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | module Main (main) where 8 | 9 | import Criterion.Main 10 | import qualified Data.ByteString as B 11 | import qualified "stdio" Data.Vector as V 12 | import qualified Data.List as List 13 | import qualified Data.Vector.Unboxed as VU 14 | import Data.Word 15 | import Control.DeepSeq 16 | import Builder 17 | import Bytes 18 | import Text 19 | import BitTwiddle 20 | import System.IO (readFile) 21 | import qualified "text" Data.Text as T 22 | import qualified "stdio" Data.Text as S 23 | 24 | main :: IO () 25 | main = do 26 | str <- readFile "test/utf8-sample.txt" 27 | let t = T.pack str 28 | st = S.pack str 29 | defaultMain -- $ List.reverse -- uncomment this reverse bench, useful for dev 30 | [ bgroup "Bytes" bytes 31 | , bgroup "Builder" builder 32 | , bgroup "BitTwiddle" bitTwiddle 33 | , bgroup "Text" (text t st) 34 | ] 35 | 36 | -------------------------------------------------------------------------------- /bench/Text.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE PackageImports #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | module Text (text) where 8 | 9 | import Criterion.Main 10 | import qualified Data.ByteString as BS 11 | import qualified "text" Data.Text as T 12 | import qualified "stdio" Data.Text as S 13 | import qualified "stdio" Data.Vector as V 14 | import Control.DeepSeq 15 | import Control.Monad 16 | import Control.Exception (evaluate) 17 | import Data.Monoid ((<>)) 18 | import Data.Word 19 | import qualified Data.List as List 20 | 21 | import Prelude hiding (reverse,head,tail,last,init,null 22 | ,length,map,lines,foldl,foldr,unlines 23 | ,concat,any,take,drop,splitAt,takeWhile 24 | ,dropWhile,span,break,elem,filter,maximum 25 | ,minimum,all,concatMap,foldl1,foldr1 26 | ,scanl,scanl1,scanr,scanr1 27 | ,readFile,writeFile,appendFile,replicate 28 | ,getContents,getLine,putStr,putStrLn,interact 29 | ,zip,zipWith,unzip,notElem 30 | ) 31 | 32 | text :: T.Text -> S.Text -> [Benchmark] 33 | text t st = List.reverse 34 | [ bgroup "pack" (pack1000 t st) 35 | , bgroup "unpack" (unpack1000 t st) 36 | , bgroup "last" (last t st) 37 | , bgroup "length" (length t st) 38 | , bgroup "map" (map t st) 39 | , bgroup "reverse" (reverse t st) 40 | ] 41 | 42 | unpack1000 :: T.Text -> S.Text -> [Benchmark] 43 | unpack1000 t st = 44 | [ bench "text/unpack" $ nf T.unpack t 45 | , bench "stdio text/unpack" $ nf S.unpack st 46 | ] 47 | 48 | pack1000 :: T.Text -> S.Text -> [Benchmark] 49 | pack1000 t st = 50 | [ bench "text/pack" $ nf T.pack (List.replicate 1000 '0') 51 | , bench "stdio text/pack" $ nf S.pack (List.replicate 1000 '0') 52 | ] 53 | 54 | last :: T.Text -> S.Text -> [Benchmark] 55 | last t st = 56 | [ bench "text/last" $ nf T.last t 57 | , bench "stdio text/last" $ nf S.last st 58 | ] 59 | 60 | length :: T.Text -> S.Text -> [Benchmark] 61 | length t st = 62 | [ bench "text/length" $ nf T.length t 63 | , bench "stdio text/length" $ nf S.length st 64 | ] 65 | 66 | map :: T.Text -> S.Text -> [Benchmark] 67 | map t st = 68 | [ bench "text/map" $ nf (T.map id) t 69 | , bench "stdio text/map" $ nf (S.map id) st 70 | ] 71 | 72 | reverse :: T.Text -> S.Text -> [Benchmark] 73 | reverse t st = 74 | [ bench "text/reverse" $ nf T.reverse t 75 | , bench "stdio text/reverse" $ nf S.reverse st 76 | ] 77 | -------------------------------------------------------------------------------- /bench/diskIO/AutoFFI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main where 3 | 4 | import System.Posix.Internals (c_read, c_open, c_close, c_write, o_RDWR, o_CREAT, o_NONBLOCK) 5 | import System.Posix.Internals (c_safe_read, c_safe_open, c_close, c_safe_write, o_RDWR, o_CREAT, o_NONBLOCK) 6 | import Foreign.C.String 7 | import Foreign.Marshal.Alloc 8 | import Control.Monad 9 | import Control.Concurrent.Async (forConcurrently_) 10 | import Control.Concurrent (getNumCapabilities) 11 | import System.Environment 12 | import Data.Bits 13 | import Data.IORef.Unboxed 14 | import System.IO.Unsafe 15 | #if defined(mingw32_HOST_OS) 16 | import Foreign.Ptr (castPtr) 17 | #endif 18 | 19 | unsafeCounter :: Counter 20 | unsafeCounter = unsafePerformIO $ do newCounter 0 21 | {-# NOINLINE unsafeCounter #-} 22 | 23 | main :: IO () 24 | main = do 25 | [file] <- getArgs 26 | forConcurrently_ [0..100] $ \ i -> do 27 | let file' = file ++ "-" ++ show i 28 | withCString file $ \ fp -> do 29 | withCString file' $ \ fp' -> do 30 | #if defined(mingw32_HOST_OS) 31 | fd <- c_open (castPtr fp) (o_RDWR .|. o_NONBLOCK) 0o666 32 | fd' <- c_open (castPtr fp') (o_CREAT .|. o_RDWR .|. o_NONBLOCK) 0o666 33 | #else 34 | fd <- c_open fp (o_RDWR .|. o_NONBLOCK) 0o666 35 | fd' <- c_open fp' (o_CREAT .|. o_RDWR .|. o_NONBLOCK) 0o666 36 | #endif 37 | loop fd fd' 38 | c_close fd 39 | c_close fd' 40 | 41 | where 42 | loop fd fd' = do 43 | ptr <- mallocBytes 32750 44 | siz <- do 45 | uc <- readIORefU unsafeCounter 46 | tc <- getNumCapabilities 47 | if uc >= tc `div` 2 48 | then do 49 | c_safe_read fd ptr 32750 50 | else do 51 | atomicAddCounter unsafeCounter 1 52 | siz <- c_read fd ptr 32750 53 | atomicSubCounter unsafeCounter 1 54 | return siz 55 | 56 | loopWrite fd' ptr (fromIntegral siz) 57 | free ptr 58 | case siz `compare` 0 of 59 | LT -> error ("error:" ++ show siz) 60 | EQ -> return () 61 | GT -> loop fd fd' 62 | 63 | 64 | loopWrite fd ptr n = do 65 | siz <- do 66 | uc <- readIORefU unsafeCounter 67 | tc <- getNumCapabilities 68 | if uc >= tc `div` 2 69 | then fromIntegral `fmap` c_safe_write fd ptr n 70 | else do 71 | atomicAddCounter unsafeCounter 1 72 | siz <- fromIntegral `fmap` c_write fd ptr n 73 | atomicSubCounter unsafeCounter 1 74 | return siz 75 | 76 | case siz `compare` n of 77 | LT -> loopWrite fd ptr (n - siz) 78 | EQ -> return () 79 | GT -> error ("over write:" ++ show siz) 80 | -------------------------------------------------------------------------------- /bench/diskIO/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, winter 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of winter nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /bench/diskIO/README.md: -------------------------------------------------------------------------------- 1 | Benchmark for different Disk IO 2 | =============================== 3 | 4 | Unlike socket I/O which is event based in almost all modern OS, event based disk I/O is quite fragile. For example to provide an async interface for disk files, libuv use a thread pool, the same story goes with glibc's AIO support. The complexity lies in that there're so many layers of buffering between user space programs and the hardware, and even OS provides a true event based interface for programmers, they probably should not use them since programmers can't see overall disk activities like OS do: 5 | They'd better start multiple threads and leave disk I/O scheduling to OS. 6 | 7 | In haskell we trust I/O manager to do I/O scheduling. In the case of disk I/O, the thing get quite messy: `select/poll/epoll` will report disk files are readable and writable any time we ask them, then we do a blocking read or write immediately which are unsafe calls. This is not good because unsafe calls will block GHC's runtime, they also make GC's latency unpredictable. 8 | 9 | On the other hand, if we only use safe FFI to make disk I/O, we're simply forking new OS threads, which can be too many. And the safe FFI overhead is taxing us. But we may get better runtime characteristics. 10 | 11 | I also add a limited pool version, which works by limited all unsafe I/O operastions to only 3 threads, and use `MVar` to sync, which mimic a thread pool: There're at most 3 threads performing disk I/O, so the whole system is not blocked with `-N4`. In practice the pool size should be adjust by capacity number though. 12 | 13 | The choice is very hard to make, because disk I/O operastions is very unpredictable in duration, This test is to test each of the options we have, and try hopefully to find the best one. 14 | 15 | Run test 16 | -------- 17 | 18 | ``` 19 | cabal build 20 | time dist/build/unsafe-ffi/unsafe-ffi 1k 21 | time dist/build/select/select 1k 22 | time dist/build/safe-ffi/safe-ffi 1k 23 | time dist/build/thread-pool/thread-pool 1k 24 | time dist/build/unsafe-ffi/unsafe-ffi 1m 25 | time dist/build/select/select 1m 26 | time dist/build/safe-ffi/safe-ffi 1m 27 | time dist/build/thread-pool/thread-pool 1m 28 | time dist/build/unsafe-ffi/unsafe-ffi 10m 29 | time dist/build/select/select 10m 30 | time dist/build/safe-ffi/safe-ffi 10m 31 | time dist/build/thread-pool/thread-pool 10m 32 | 33 | # clean up 34 | rm 1k-* 35 | rm 1m-* 36 | rm 10m-* 37 | ``` 38 | -------------------------------------------------------------------------------- /bench/diskIO/SafeFFI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main where 3 | 4 | import System.Posix.Internals (c_safe_read, c_safe_open, c_close, c_safe_write, o_RDWR, o_CREAT, o_NONBLOCK) 5 | import Foreign.C.String 6 | import Foreign.Marshal.Alloc 7 | import Control.Monad 8 | import Control.Concurrent.Async (forConcurrently_) 9 | import System.Environment 10 | import Data.Bits 11 | #if defined(mingw32_HOST_OS) 12 | import Foreign.Ptr (castPtr) 13 | #endif 14 | 15 | main :: IO () 16 | main = do 17 | [file] <- getArgs 18 | forConcurrently_ [0..100] $ \ i -> do 19 | let file' = file ++ "-" ++ show i 20 | withCString file $ \ fp -> do 21 | withCString file' $ \ fp' -> do 22 | #if defined(mingw32_HOST_OS) 23 | fd <- c_safe_open (castPtr fp) (o_RDWR .|. o_NONBLOCK) 0o666 24 | fd' <- c_safe_open (castPtr fp') (o_CREAT .|. o_RDWR .|. o_NONBLOCK) 0o666 25 | #else 26 | fd <- c_safe_open fp (o_RDWR .|. o_NONBLOCK) 0o666 27 | fd' <- c_safe_open fp' (o_CREAT .|. o_RDWR .|. o_NONBLOCK) 0o666 28 | #endif 29 | loop fd fd' 30 | c_close fd 31 | c_close fd' 32 | 33 | where 34 | loop fd fd' = do 35 | ptr <- mallocBytes 32750 36 | siz <- c_safe_read fd ptr 32750 37 | loopWrite fd' ptr (fromIntegral siz) 38 | free ptr 39 | case siz `compare` 0 of 40 | LT -> error ("error:" ++ show siz) 41 | EQ -> return () 42 | GT -> loop fd fd' 43 | 44 | 45 | loopWrite fd ptr n = do 46 | siz <- fromIntegral `fmap` c_safe_write fd ptr n 47 | case siz `compare` n of 48 | LT -> loopWrite fd ptr (n - siz) 49 | EQ -> return () 50 | GT -> error ("over write:" ++ show siz) 51 | -------------------------------------------------------------------------------- /bench/diskIO/Select.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import GHC.IO.FD 4 | import Foreign.Marshal.Alloc 5 | import Control.Monad 6 | import Control.Concurrent.Async (forConcurrently_) 7 | import System.Environment 8 | import Data.Bits 9 | import GHC.IO.Device 10 | import GHC.IO.IOMode 11 | import Prelude hiding (read) 12 | 13 | main :: IO () 14 | main = do 15 | [file] <- getArgs 16 | forConcurrently_ [0..100] $ \ i -> do 17 | let file' = file ++ "-" ++ show i 18 | (fd, _) <- openFile file ReadMode True 19 | (fd', _) <- openFile file' ReadWriteMode True 20 | loop fd fd' 21 | close fd 22 | close fd' 23 | 24 | where 25 | loop fd fd' = do 26 | ptr <- mallocBytes 32750 27 | siz <- read fd ptr 32750 28 | write fd' ptr (fromIntegral siz) 29 | free ptr 30 | case siz `compare` 0 of 31 | LT -> error ("error:" ++ show siz) 32 | EQ -> return () 33 | GT -> loop fd fd' 34 | -------------------------------------------------------------------------------- /bench/diskIO/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bench/diskIO/ThreadPool.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main where 3 | 4 | import System.Posix.Internals (c_read, c_open, c_close, c_write, o_RDWR, o_CREAT, o_NONBLOCK) 5 | import System.Posix.Types 6 | import Foreign.C.String 7 | import Foreign.Marshal.Alloc 8 | import Control.Monad 9 | import Control.Concurrent.Async (forConcurrently_) 10 | import Control.Concurrent 11 | import Control.Concurrent.MVar 12 | import System.Environment 13 | import Data.Bits 14 | import Data.IORef 15 | import Data.Word 16 | import Foreign.Ptr 17 | import Foreign.C.Types 18 | import GHC.Prim (Any) 19 | import Unsafe.Coerce (unsafeCoerce) 20 | #if defined(mingw32_HOST_OS) 21 | import Foreign.Ptr (castPtr) 22 | #endif 23 | 24 | data Job = Job (MVar (IO Any)) (MVar Any) 25 | 26 | newEmptyJob = do 27 | req <- newEmptyMVar 28 | res <- newEmptyMVar 29 | return (Job req res) 30 | 31 | submitJob :: Job -> IO a -> IO a 32 | submitJob (Job req res) io = do 33 | putMVar req (unsafeCoerce `fmap` io) 34 | unsafeCoerce `fmap` takeMVar res 35 | 36 | startWorkerOn :: Int -> Job -> IO ThreadId 37 | startWorkerOn cap (Job req res) = forkOn cap . forever $ do 38 | request <- takeMVar req 39 | r <- request 40 | putMVar res r 41 | 42 | main :: IO () 43 | main = do 44 | [file] <- getArgs 45 | 46 | j1 <- newEmptyJob 47 | j2 <- newEmptyJob 48 | j3 <- newEmptyJob 49 | 50 | startWorkerOn 0 j1 -- For test purpose 51 | startWorkerOn 1 j2 52 | startWorkerOn 2 j3 53 | 54 | 55 | forConcurrently_ [0..100] $ \ i -> do 56 | let file' = file ++ "-" ++ show i 57 | job = case i `mod` 3 of 1 -> j1 58 | 2 -> j2 59 | _ -> j3 60 | withCString file $ \ fp -> do 61 | withCString file' $ \ fp' -> submitJob job $ do 62 | #if defined(mingw32_HOST_OS) 63 | fd <- c_open (castPtr fp) (o_RDWR .|. o_NONBLOCK) 0o666 64 | fd' <- c_open (castPtr fp') (o_CREAT .|. o_RDWR .|. o_NONBLOCK) 0o666 65 | #else 66 | fd <- c_open fp (o_RDWR .|. o_NONBLOCK) 0o666 67 | fd' <- c_open fp' (o_CREAT .|. o_RDWR .|. o_NONBLOCK) 0o666 68 | #endif 69 | loop fd fd' 70 | c_close fd 71 | c_close fd' 72 | 73 | where 74 | 75 | loop fd fd' = do 76 | ptr <- mallocBytes 32750 77 | siz <- c_read fd ptr 32750 78 | loopWrite fd' ptr (fromIntegral siz) 79 | free ptr 80 | case siz `compare` 0 of 81 | LT -> error ("error:" ++ show siz) 82 | EQ -> return () 83 | GT -> loop fd fd' 84 | 85 | 86 | loopWrite fd ptr n = do 87 | siz <- fromIntegral `fmap` c_write fd ptr n 88 | case siz `compare` n of 89 | LT -> loopWrite fd ptr (n - siz) 90 | EQ -> return () 91 | GT -> error ("over write:" ++ show siz) 92 | -------------------------------------------------------------------------------- /bench/diskIO/UnSafeFFI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main where 3 | 4 | import System.Posix.Internals (c_read, c_open, c_close, c_write, o_RDWR, o_CREAT, o_NONBLOCK) 5 | import Foreign.C.String 6 | import Foreign.Marshal.Alloc 7 | import Control.Monad 8 | import Control.Concurrent.Async (forConcurrently_) 9 | import System.Environment 10 | import Data.Bits 11 | #if defined(mingw32_HOST_OS) 12 | import Foreign.Ptr (castPtr) 13 | #endif 14 | 15 | main :: IO () 16 | main = do 17 | [file] <- getArgs 18 | forConcurrently_ [0..100] $ \ i -> do 19 | let file' = file ++ "-" ++ show i 20 | withCString file $ \ fp -> do 21 | withCString file' $ \ fp' -> do 22 | #if defined(mingw32_HOST_OS) 23 | fd <- c_open (castPtr fp) (o_RDWR .|. o_NONBLOCK) 0o666 24 | fd' <- c_open (castPtr fp') (o_CREAT .|. o_RDWR .|. o_NONBLOCK) 0o666 25 | #else 26 | fd <- c_open fp (o_RDWR .|. o_NONBLOCK) 0o666 27 | fd' <- c_open fp' (o_CREAT .|. o_RDWR .|. o_NONBLOCK) 0o666 28 | #endif 29 | loop fd fd' 30 | c_close fd 31 | c_close fd' 32 | 33 | where 34 | loop fd fd' = do 35 | ptr <- mallocBytes 32750 36 | siz <- c_read fd ptr 32750 37 | loopWrite fd' ptr (fromIntegral siz) 38 | free ptr 39 | case siz `compare` 0 of 40 | LT -> error ("error:" ++ show siz) 41 | EQ -> return () 42 | GT -> loop fd fd' 43 | 44 | 45 | loopWrite fd ptr n = do 46 | siz <- fromIntegral `fmap` c_write fd ptr n 47 | case siz `compare` n of 48 | LT -> loopWrite fd ptr (n - siz) 49 | EQ -> return () 50 | GT -> error ("over write:" ++ show siz) 51 | -------------------------------------------------------------------------------- /bench/diskIO/diskIO.cabal: -------------------------------------------------------------------------------- 1 | -- Initial diskIO.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: diskIO 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: winter 11 | maintainer: handong@xiaomi.com 12 | -- copyright: 13 | category: Testing 14 | build-type: Simple 15 | extra-source-files: ChangeLog.md 16 | cabal-version: >=1.10 17 | 18 | executable safe-ffi 19 | main-is: SafeFFI.hs 20 | -- other-modules: 21 | -- other-extensions: 22 | build-depends: base >=4.9 && <4.10 23 | , async 24 | -- hs-source-dirs: 25 | default-language: Haskell2010 26 | ghc-options: -threaded 27 | 28 | executable unsafe-ffi 29 | main-is: UnSafeFFI.hs 30 | -- other-modules: 31 | -- other-extensions: 32 | build-depends: base >=4.9 && <4.10 33 | , async 34 | -- hs-source-dirs: 35 | default-language: Haskell2010 36 | ghc-options: -threaded -with-rtsopts=-N8 37 | 38 | executable thread-pool 39 | main-is: ThreadPool.hs 40 | -- other-modules: 41 | -- other-extensions: 42 | build-depends: base >=4.9 && <4.10 43 | , async 44 | , ghc-prim 45 | -- hs-source-dirs: 46 | default-language: Haskell2010 47 | ghc-options: -threaded -with-rtsopts=-N8 48 | 49 | executable select 50 | 51 | main-is: Select.hs 52 | -- other-modules: 53 | -- other-extensions: 54 | build-depends: base >=4.9 && <4.10 55 | , async 56 | -- hs-source-dirs: 57 | default-language: Haskell2010 58 | ghc-options: -threaded -with-rtsopts=-N8 59 | 60 | executable auto-ffi 61 | 62 | main-is: AutoFFI.hs 63 | -- other-modules: 64 | -- other-extensions: 65 | build-depends: base >=4.9 && <4.10 66 | , async 67 | , unboxed-ref 68 | -- hs-source-dirs: 69 | default-language: Haskell2010 70 | ghc-options: -threaded -with-rtsopts=-N8 71 | -------------------------------------------------------------------------------- /bench/tcp/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for y 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /bench/tcp/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, handong 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of handong nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /bench/tcp/LibUV.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Main where 5 | 6 | import System.IO.Net 7 | import System.IO.Buffered 8 | import Control.Concurrent 9 | import Foreign.ForeignPtr 10 | import qualified Data.ByteString as B 11 | import qualified Data.ByteString.Internal as B 12 | import GHC.ForeignPtr 13 | import Control.Monad 14 | import System.IO.Exception 15 | import System.IO.UV.Stream 16 | import System.IO 17 | import Data.IORef.Unboxed 18 | import System.Environment 19 | import Text.Read (readMaybe) 20 | 21 | main :: IO () 22 | main = do 23 | portStr <- lookupEnv "PORT" 24 | let port = maybe 8888 id (readMaybe =<< portStr) 25 | let conf = ServerConfig 26 | (SockAddrInet port inetAny) 27 | 128 28 | (\ uvs -> do 29 | recvbuf <- mallocPlainForeignPtrBytes 2048 -- we reuse buffer as golang does, 30 | -- since node use slab, which is in face a memory pool 31 | echo uvs recvbuf) 32 | True 33 | (print :: SomeException -> IO()) 34 | 35 | startServer conf 36 | where 37 | echo uvs recvbuf = loop 38 | where 39 | loop = do 40 | r <- withForeignPtr recvbuf $ \ p -> do 41 | readInput uvs p 2048 42 | when (r /= 0) $ do 43 | withForeignPtr sendbuffp $ \ p -> writeOutput uvs p l 44 | loop 45 | 46 | (B.PS sendbuffp _ l) = 47 | "HTTP/1.1 200 OK\r\n\ 48 | \Content-Type: text/html; charset=UTF-8\r\n\ 49 | \Content-Length: 500\r\n\ 50 | \Connection: Keep-Alive\r\n\ 51 | \\r\n" `B.append` (B.replicate 500 48) 52 | 53 | 54 | 55 | 56 | -------------------------------------------------------------------------------- /bench/tcp/MIO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Network.Socket hiding (send, recv) 6 | import Network.Socket.ByteString 7 | import GHC.ForeignPtr 8 | import Foreign.ForeignPtr 9 | import Control.Concurrent 10 | import Control.Monad 11 | import qualified Data.ByteString as B 12 | import Control.Concurrent.MVar 13 | import Data.IORef.Unboxed 14 | import System.Environment 15 | import Text.Read (readMaybe) 16 | 17 | main :: IO () 18 | main = do 19 | portStr <- lookupEnv "PORT" 20 | let port = maybe 8888 id (readMaybe =<< portStr) 21 | sock <- socket AF_INET Stream defaultProtocol 22 | bind sock $ SockAddrInet port iNADDR_ANY 23 | listen sock 128 24 | cap <- getNumCapabilities 25 | capCounter <- newCounter 0 26 | forever $ do 27 | (sock' , addr) <- accept sock 28 | c <- atomicAddCounter_ capCounter 1 29 | forkOn c $ do 30 | setSocketOption sock' NoDelay 1 31 | recvbuf <- mallocPlainForeignPtrBytes 2048 -- we reuse buffer as golang does, 32 | -- since node use slab, which is in face a memory pool 33 | echo sock' recvbuf 34 | where 35 | echo sock recvbuf = loop 36 | where 37 | loop = do 38 | r <- withForeignPtr recvbuf $ \ p -> do 39 | recvBuf sock p 2048 40 | 41 | when (r /= 0) $ do 42 | sendAll sock sendbuf 43 | loop 44 | 45 | sendbuf = 46 | "HTTP/1.1 200 OK\r\n\ 47 | \Content-Type: text/html; charset=UTF-8\r\n\ 48 | \Content-Length: 500\r\n\ 49 | \Connection: Keep-Alive\r\n\ 50 | \\r\n" `B.append` (B.replicate 500 48) 51 | 52 | -------------------------------------------------------------------------------- /bench/tcp/README.md: -------------------------------------------------------------------------------- 1 | Benchmark for new libuv I/O manager 2 | =============================== 3 | 4 | This benchmark compares following I/O multiplexers: 5 | 6 | + current one in base, aka. mio 7 | 8 | This is an M:N multiplexers, each OS thread(capability in GHC rts) use a kqueue/epoll fd to do event polling, and one haskell thread to manager the poller. 9 | 10 | + libuv I/O manager in stdio 11 | 12 | This is an M:N multiplexers just like mio, but use libuv as OSes abstraction, each OS thread(capability in GHC rts) use an `uv_loop` poller, and one haskell thread to mananger the poller. 13 | 14 | + golang's netpoller 15 | 16 | This is an M:N multiplexers, but golang rts only start one extra thread doing I/O multiplex, M user threads on N OS threads all request I/O scheduling from this poller thread. 17 | 18 | + nodejs cluster 19 | 20 | This is a single threaded multiplexers, but use multiples process to take advantage of multiple CPU. 21 | 22 | 23 | Run test 24 | -------- 25 | 26 | This benchmark will start a server on your localhost's 8888 port(or use PORT environment varible if available), read some input(and ignore them), them servering 500 bytes of zeros in HTTP protocal, so that you can use HTTP benchmark tools such as `siege` or `wrk` to bench. A small respond size is choosen to highlight overhead each multiplexer added. 27 | 28 | You should adjust your system's fd limit before running benchmark in case of running out of fd. 29 | 30 | ``` 31 | cabal build 32 | 33 | # Adding a proper heap size hint is important for haskell programs because 34 | # the way GHC's GC works. 35 | # You should use a -Hx parammeter if the concurrent level go beyong ~1k. 36 | # Quick formula: concurrent level(in K) * 10M, for example use -H128M for C10K. 37 | 38 | # mio, if you know your CPU's core number x, append a -Nx 39 | ./dist/build/mio/mio +RTS -s 40 | 41 | # stdio, if you know your CPU's core number x, append a -Nx 42 | ./dist/build/libuv/libuv +RTS -s 43 | 44 | # golang 45 | go run golang/main.go 46 | 47 | # nodejs, if you know your CPU's core number x, set it with env CPU_NUM=x 48 | node nodejs/main.js 49 | 50 | # wrk 51 | wrk -c1000 -d10s http://127.0.0.1:8888 52 | 53 | # siege 54 | siege -c 1000 -r 10 http://127.0.0.1:8888 55 | 56 | # ab 57 | ab -r -k -c 100 -n 30000 http://127.0.0.1:8888/ 58 | ... 59 | ``` 60 | -------------------------------------------------------------------------------- /bench/tcp/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bench/tcp/golang/main.go: -------------------------------------------------------------------------------- 1 | package main 2 | 3 | import ( 4 | "fmt" 5 | "net" 6 | "os" 7 | ) 8 | 9 | const ( 10 | CONN_HOST = "localhost" 11 | CONN_TYPE = "tcp" 12 | ) 13 | 14 | func main() { 15 | // Listen for incoming connections. 16 | port := "8888" 17 | if os.Getenv("PORT") != "" { 18 | port = os.Getenv("PORT") 19 | } 20 | l, err := net.Listen(CONN_TYPE, CONN_HOST+":"+port) 21 | if err != nil { 22 | fmt.Println("Error listening:", err.Error()) 23 | os.Exit(1) 24 | } 25 | // Close the listener when the application closes. 26 | defer l.Close() 27 | fmt.Println("Listening on " + CONN_HOST + ":" + port) 28 | for { 29 | // Listen for an incoming connection. 30 | conn, err := l.Accept() 31 | if err != nil { 32 | fmt.Println("Error accepting: ", err.Error()) 33 | os.Exit(1) 34 | } 35 | // Handle connections in a new goroutine. 36 | go handleRequest(conn) 37 | } 38 | } 39 | 40 | // Handles incoming requests. 41 | func handleRequest(conn net.Conn) { 42 | // Make a buffer to hold incoming data. 43 | buf := make([]byte, 2048) 44 | 45 | for { 46 | // Read the incoming connection into the buffer. 47 | _, err := conn.Read(buf) 48 | if err == nil { 49 | // Send a response back to person contacting us. 50 | conn.Write([]byte( 51 | "HTTP/1.1 200 OK\r\n" + 52 | "Content-Type: text/html; charset=UTF-8\r\n" + 53 | "Content-Length: 500\r\n" + 54 | "Connection: Keep-Alive\r\n\r\n" + "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000")) 55 | } else { 56 | // Close the connection when you're done with it. 57 | conn.Close() 58 | break 59 | } 60 | } 61 | } 62 | -------------------------------------------------------------------------------- /bench/tcp/nodejs/main.js: -------------------------------------------------------------------------------- 1 | var net = require('net'); 2 | var cluster = require('cluster'); 3 | var numCPUs = process.env.CPU_NUM | 4; 4 | var port = process.env.PORT | 8888; 5 | 6 | if (cluster.isMaster) { 7 | for (var i = 0; i < numCPUs; i++) { 8 | cluster.fork(); 9 | } 10 | } else { 11 | var server = net.createServer(function(socket) { 12 | socket.on('data', function(data){ 13 | socket.write(respond); 14 | }) 15 | }); 16 | server.listen(port); 17 | } 18 | 19 | var respond = 20 | 21 | "HTTP/1.1 200 OK\r\n\ 22 | Content-Type: text/html; charset=UTF-8\r\n\ 23 | Content-Length: 500\r\n\ 24 | Connection: Keep-Alive\r\n\r\n\ 25 | 00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /bench/tcp/tcp.cabal: -------------------------------------------------------------------------------- 1 | -- Initial y.cabal generated by cabal init. For further documentation, see 2 | -- http://haskell.org/cabal/users-guide/ 3 | 4 | name: tcp 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: handong 11 | maintainer: handong@xiaomi.com 12 | -- copyright: 13 | category: Concurrency 14 | build-type: Simple 15 | extra-source-files: ChangeLog.md 16 | cabal-version: >=1.10 17 | 18 | executable libuv 19 | main-is: LibUV.hs 20 | other-modules: System.IO.Buffered 21 | System.IO.Net 22 | System.IO.Net.SockAddr 23 | System.IO.UV.Exception 24 | System.IO.UV.Internal 25 | -- other-extensions: 26 | c-sources: ../../cbits/bytes.c 27 | ../../cbits/hs_uv.c 28 | 29 | build-depends: base >=4.9 && <5.0 30 | , stm 31 | , ghc-prim 32 | , primitive 33 | , unboxed-ref 34 | , network 35 | , template-haskell 36 | , deepseq 37 | , async 38 | , bytestring 39 | 40 | include-dirs: ../../include 41 | includes: hs_uv.h 42 | hs-source-dirs: ./ 43 | ../../ 44 | 45 | if os(windows) 46 | include-dirs: 47 | ../../third_party/libuv/include 48 | c-sources: 49 | -- Note: The c-sources list is taken from libuv's Makefile.mingw, needs to be 50 | -- updated when we bump up libuv's version. 51 | ../../third_party/libuv/src/fs-poll.c 52 | , ../../third_party/libuv/src/inet.c 53 | , ../../third_party/libuv/src/threadpool.c 54 | , ../../third_party/libuv/src/uv-common.c 55 | , ../../third_party/libuv/src/version.c 56 | , ../../third_party/libuv/src/win/async.c 57 | , ../../third_party/libuv/src/win/core.c 58 | , ../../third_party/libuv/src/win/detect-wakeup.c 59 | , ../../third_party/libuv/src/win/dl.c 60 | , ../../third_party/libuv/src/win/error.c 61 | , ../../third_party/libuv/src/win/fs-event.c 62 | , ../../third_party/libuv/src/win/fs.c 63 | , ../../third_party/libuv/src/win/getaddrinfo.c 64 | , ../../third_party/libuv/src/win/getnameinfo.c 65 | , ../../third_party/libuv/src/win/handle.c 66 | , ../../third_party/libuv/src/win/loop-watcher.c 67 | , ../../third_party/libuv/src/win/pipe.c 68 | , ../../third_party/libuv/src/win/poll.c 69 | , ../../third_party/libuv/src/win/process-stdio.c 70 | , ../../third_party/libuv/src/win/process.c 71 | , ../../third_party/libuv/src/win/req.c 72 | , ../../third_party/libuv/src/win/signal.c 73 | , ../../third_party/libuv/src/win/stream.c 74 | , ../../third_party/libuv/src/win/tcp.c 75 | , ../../third_party/libuv/src/win/thread.c 76 | , ../../third_party/libuv/src/win/timer.c 77 | , ../../third_party/libuv/src/win/tty.c 78 | , ../../third_party/libuv/src/win/udp.c 79 | , ../../third_party/libuv/src/win/util.c 80 | , ../../third_party/libuv/src/win/winapi.c 81 | , ../../third_party/libuv/src/win/winsock.c 82 | ghc-options: -DWIN32_LEAN_AND_MEAN -D_WIN32_WINNT=0x0600 83 | cc-options: -Wall -Wextra -Wno-unused-parameter -Wstrict-prototypes -DWIN32_LEAN_AND_MEAN -D_WIN32_WINNT=0x0600 -I../../third_party/libuv/src -I../../third_party/libuv/src/win 84 | extra-libraries: psapi, Iphlpapi, userenv 85 | 86 | else 87 | extra-libraries: uv 88 | 89 | ghc-options: -O2 -threaded -rtsopts -eventlog -with-rtsopts=-N 90 | default-language: Haskell2010 91 | 92 | 93 | executable mio 94 | main-is: MIO.hs 95 | -- other-modules: 96 | -- other-extensions: 97 | build-depends: base >=4.9 && <5.0 98 | , network 99 | , stm 100 | , async 101 | , bytestring 102 | , unboxed-ref 103 | hs-source-dirs: ./ 104 | ghc-options: -O2 -threaded -rtsopts -eventlog -with-rtsopts=-N 105 | default-language: Haskell2010 106 | -------------------------------------------------------------------------------- /bench/timers/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for y 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /bench/timers/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, handong 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of handong nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /bench/timers/LowResTimer.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Concurrent.STM 4 | import Control.Concurrent 5 | import Control.Monad 6 | import System.LowResTimer 7 | 8 | main :: IO () 9 | main = do 10 | r <- newTVarIO 0 :: IO (TVar Int) 11 | 12 | replicateM 100000 . forkIO $ do 13 | forM_ [1..10] $ \ i -> do 14 | registerLowResTimer (i*10) (atomically $ modifyTVar' r (+1)) 15 | 16 | atomically $ do 17 | r' <- readTVar r 18 | unless (r' == 1000000) retry 19 | 20 | -------------------------------------------------------------------------------- /bench/timers/README.md: -------------------------------------------------------------------------------- 1 | Benchmark for different Disk IO 2 | =============================== 3 | 4 | High performance timers are always the base for I/O libraries. Although base provide high precision timers based on min heap and OS's timers, the performance is not satisfactory when there's a large quantity of timeouts. This test benchmark our new low resolutin timers based on timing wheel with the one in base. 5 | 6 | Run test 7 | -------- 8 | 9 | ``` 10 | cabal build 11 | ./dist/build/system-timer/system-timer +RTS -s 12 | ./dist/build/low-res-timer/low-res-timer +RTS -s 13 | ``` 14 | -------------------------------------------------------------------------------- /bench/timers/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bench/timers/SystemTimer.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Concurrent.STM 4 | import Control.Concurrent 5 | import Control.Monad 6 | import GHC.Event 7 | 8 | main :: IO () 9 | main = do 10 | r <- newTVarIO 0 :: IO (TVar Int) 11 | 12 | tm <- getSystemTimerManager 13 | 14 | replicateM 100000 . forkIO $ do 15 | forM_ [1..10] $ \ i -> do 16 | registerTimeout tm (i*1000000) (atomically $ modifyTVar' r (+1)) 17 | 18 | atomically $ do 19 | r' <- readTVar r 20 | unless (r' == 1000000) retry 21 | 22 | -------------------------------------------------------------------------------- /bench/timers/timers.cabal: -------------------------------------------------------------------------------- 1 | -- Initial y.cabal generated by cabal init. For further documentation, see 2 | -- http://haskell.org/cabal/users-guide/ 3 | 4 | name: timers 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: handong 11 | maintainer: handong@xiaomi.com 12 | -- copyright: 13 | category: Concurrency 14 | build-type: Simple 15 | extra-source-files: ChangeLog.md 16 | cabal-version: >=1.10 17 | 18 | executable low-res-timer 19 | main-is: LowResTimer.hs 20 | -- other-modules: 21 | -- other-extensions: 22 | c-sources: ../../cbits/bytes.c 23 | build-depends: base >=4.9 && <5.0 24 | , stm 25 | , ghc-prim 26 | , primitive 27 | , unboxed-ref 28 | hs-source-dirs: ./ 29 | ../../ 30 | ghc-options: -O2 -threaded -with-rtsopts=-N4 31 | default-language: Haskell2010 32 | 33 | 34 | executable system-timer 35 | main-is: SystemTimer.hs 36 | -- other-modules: 37 | -- other-extensions: 38 | build-depends: base >=4.9 && <5.0 39 | , stm 40 | hs-source-dirs: ./ 41 | ghc-options: -O2 -threaded -with-rtsopts=-N4 42 | default-language: Haskell2010 43 | if os(windows) 44 | buildable: False 45 | -------------------------------------------------------------------------------- /cbits/bytes.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "Rts.h" 4 | 5 | int _memcmp(char *a, 6 | size_t aoff, 7 | char *b, 8 | size_t boff, 9 | size_t n) { 10 | a += aoff; 11 | b += boff; 12 | return memcmp(a, b, n); 13 | } 14 | 15 | size_t _memchr(char *a, 16 | size_t aoff, 17 | char b, 18 | size_t n) { 19 | a += aoff; 20 | return (char*)memchr(a, b, n) - a; 21 | } 22 | 23 | 24 | int is_byte_array_pinned(unsigned char* p){ 25 | return Bdescr((StgPtr)p)->flags & (BF_PINNED | BF_LARGE); 26 | } 27 | -------------------------------------------------------------------------------- /cbits/text.c: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/winterland1989/stdio/122d9ff5381e66a87b5d810a23b8d4ec82f5b5c4/cbits/text.c -------------------------------------------------------------------------------- /docs/_config.yml: -------------------------------------------------------------------------------- 1 | theme: jekyll-theme-dinky -------------------------------------------------------------------------------- /docs/index.md: -------------------------------------------------------------------------------- 1 | Design overview 2 | =============== 3 | -------------------------------------------------------------------------------- /docs/stdio/System-IO-FileSystem-Slow.html: -------------------------------------------------------------------------------- 1 | System.IO.FileSystem.Slow

stdio-0.1.0.0: Standard Input and Output for Haskell

Safe HaskellNone
LanguageHaskell2010

System.IO.FileSystem.Slow

Documentation

scandir :: CBytes -> IO [(CBytes, UVDirEntType)] #

-------------------------------------------------------------------------------- /docs/stdio/System-IO-FileSystem.html: -------------------------------------------------------------------------------- 1 | System.IO.FileSystem

stdio-0.1.0.0: Standard Input and Output for Haskell

Safe HaskellNone
LanguageHaskell2010

System.IO.FileSystem

Documentation

scandir :: CBytes -> IO [(CBytes, UVDirEntType)] #

-------------------------------------------------------------------------------- /docs/stdio/System-IO-TTY.html: -------------------------------------------------------------------------------- 1 | System.IO.TTY

stdio-0.1.0.0: Standard Input and Output for Haskell

Copyright(c) Winterland 2018
LicenseBSD
Maintainerdrkoster@qq.com
Stabilityexperimental
Portabilitynon-portable
Safe HaskellNone
LanguageHaskell2010

System.IO.TTY

Description

This module provides an API for opening tty as UVStream. In most case, it will not be necessary to use this module directly

Documentation

data UVStream #

A higher level wrappe for uv_stream_t

Instances

Output UVStream # 

Methods

writeOutput :: UVStream -> Ptr Word8 -> Int -> IO () #

Input UVStream # 

Methods

readInput :: UVStream -> Ptr Word8 -> Int -> IO Int #

stdin :: UVStream #

stdout :: UVStream #

stderr :: UVStream #

-------------------------------------------------------------------------------- /docs/stdio/doc-index-126.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index - ~)

stdio-0.1.0.0: Standard Input and Output for Haskell

Index - ~

~#Foreign.PrimArray
-------------------------------------------------------------------------------- /docs/stdio/doc-index-42.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index - *)

stdio-0.1.0.0: Standard Input and Output for Haskell

Index - *

*#Foreign.PrimArray
*##Foreign.PrimArray
**##Foreign.PrimArray
-------------------------------------------------------------------------------- /docs/stdio/doc-index-43.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index - +)

stdio-0.1.0.0: Standard Input and Output for Haskell

Index - +

+#Foreign.PrimArray
+##Foreign.PrimArray
-------------------------------------------------------------------------------- /docs/stdio/doc-index-45.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index - -)

stdio-0.1.0.0: Standard Input and Output for Haskell

Index - -

-#Foreign.PrimArray
-##Foreign.PrimArray
-------------------------------------------------------------------------------- /docs/stdio/doc-index-47.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index - /)

stdio-0.1.0.0: Standard Input and Output for Haskell

Index - /

/##Foreign.PrimArray
/../Data.Text
/=#Foreign.PrimArray
/=##Foreign.PrimArray
-------------------------------------------------------------------------------- /docs/stdio/doc-index-60.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index - <)

stdio-0.1.0.0: Standard Input and Output for Haskell

Index - <

<#Foreign.PrimArray
<##Foreign.PrimArray
<=#Foreign.PrimArray
<=##Foreign.PrimArray
-------------------------------------------------------------------------------- /docs/stdio/doc-index-61.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index - =)

stdio-0.1.0.0: Standard Input and Output for Haskell

Index - =

==#Foreign.PrimArray
==##Foreign.PrimArray
-------------------------------------------------------------------------------- /docs/stdio/doc-index-62.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index - >)

stdio-0.1.0.0: Standard Input and Output for Haskell

Index - >

>#Foreign.PrimArray
>##Foreign.PrimArray
>=#Foreign.PrimArray
>=##Foreign.PrimArray
-------------------------------------------------------------------------------- /docs/stdio/doc-index-D.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index - D)

stdio-0.1.0.0: Standard Input and Output for Haskell

Index - D

dataToTag#Foreign.PrimArray
Deadlock 
1 (Data Constructor)System.IO.Exception
2 (Type/Class)System.IO.Exception
debounceSystem.LowResTimer
decodeCharData.Text.UTF8Codec
decodeChar#Data.Text.UTF8Codec
decodeCharLenData.Text.UTF8Codec
decodeCharLen#Data.Text.UTF8Codec
decodeCharLenReverseData.Text.UTF8Codec
decodeCharLenReverse#Data.Text.UTF8Codec
decodeCharReverseData.Text.UTF8Codec
decodeCharReverse#Data.Text.UTF8Codec
decodeDouble_2Int#Foreign.PrimArray
decodeDouble_Int64#Foreign.PrimArray
decodeFloat_Int#Foreign.PrimArray
DecodeResultData.Text
defaultChunkSizeData.Vector
defaultInitSizeData.Vector
defaultServerConfigSystem.IO.Net
delay#Foreign.PrimArray
DenormalSystem.IO.Exception
deRefStablePtr#Foreign.PrimArray
deRefWeak#Foreign.PrimArray
displayExceptionSystem.IO.Exception
DivideByZeroSystem.IO.Exception
divideDoubleX2#Foreign.PrimArray
divideDoubleX4#Foreign.PrimArray
divideDoubleX8#Foreign.PrimArray
divideFloat#Foreign.PrimArray
divideFloatX16#Foreign.PrimArray
divideFloatX4#Foreign.PrimArray
divideFloatX8#Foreign.PrimArray
Double#Foreign.PrimArray
double2Float#Foreign.PrimArray
double2Int#Foreign.PrimArray
DoubleBufferData.Builder
doubleBufferData.Builder
DoubleX2#Foreign.PrimArray
DoubleX4#Foreign.PrimArray
DoubleX8#Foreign.PrimArray
dropData.Vector
-------------------------------------------------------------------------------- /docs/stdio/doc-index-E.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index - E)

stdio-0.1.0.0: Standard Input and Output for Haskell

Index - E

elemData.Vector
elemIndexData.Vector
empty 
1 (Function)Data.Vector
2 (Function)Data.Text
3 (Function)Data.Builder
encodeCBytesCharData.Text.UTF8Codec
encodeCBytesChar#Data.Text.UTF8Codec
encodeCharData.Text.UTF8Codec
encodeChar#Data.Text.UTF8Codec
encodeCharLengthData.Text.UTF8Codec
ensureFreeData.Builder
EOF 
1 (Type/Class)System.IO.Exception
2 (Data Constructor)System.IO.Exception
eqAddr#Foreign.PrimArray
eqChar#Foreign.PrimArray
eqFloat#Foreign.PrimArray
eqStableName#Foreign.PrimArray
eqStablePtr#Foreign.PrimArray
eqWord#Foreign.PrimArray
ErrorCall 
1 (Data Constructor)System.IO.Exception
2 (Type/Class)System.IO.Exception
ErrorCallWithLocationSystem.IO.Exception
errorEmptyTextData.Text
evaluateSystem.IO.Exception
ExceptionSystem.IO.Exception
expDouble#Foreign.PrimArray
expFloat#Foreign.PrimArray
-------------------------------------------------------------------------------- /docs/stdio/doc-index-F.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index - F)

stdio-0.1.0.0: Standard Input and Output for Haskell

Index - F

fabsDouble#Foreign.PrimArray
fabsFloat#Foreign.PrimArray
FailureData.Parser
fetchAddIntArray#Foreign.PrimArray
fetchAndIntArray#Foreign.PrimArray
fetchNandIntArray#Foreign.PrimArray
fetchOrIntArray#Foreign.PrimArray
fetchSubIntArray#Foreign.PrimArray
fetchXorIntArray#Foreign.PrimArray
filterData.Vector
finalizeWeak#Foreign.PrimArray
finallySystem.IO.Exception
findData.Vector
Float#Foreign.PrimArray
float2Double#Foreign.PrimArray
float2Int#Foreign.PrimArray
FloatX16#Foreign.PrimArray
FloatX4#Foreign.PrimArray
FloatX8#Foreign.PrimArray
FlowInfoSystem.IO.Net.SockAddr, System.IO.Net
flushSystem.IO.Buffered
foldl'Data.Vector
foldl1'Data.Vector
foldr'Data.Vector
foldr1'Data.Vector
fork#Foreign.PrimArray
forkBaSystem.IO.UV.Manager
forkOn#Foreign.PrimArray
freezeArr 
1 (Function)Data.Array
2 (Function)Data.Array.Checked
freezeArray#Foreign.PrimArray
freezeSmallArray#Foreign.PrimArray
fromArrData.Vector
fromArrayArray#Data.Array, Data.Array.Checked
fromCStringData.CBytes
fromCStringMaybeData.CBytes
fromExceptionSystem.IO.Exception
-------------------------------------------------------------------------------- /docs/stdio/doc-index-G.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index - G)

stdio-0.1.0.0: Standard Input and Output for Haskell

Index - G

geAddr#Foreign.PrimArray
geChar#Foreign.PrimArray
geFloat#Foreign.PrimArray
getApStackVal#Foreign.PrimArray
getBlockMVarSystem.IO.UV.Manager
getCCSOf#Foreign.PrimArray
getCurrentCCS#Foreign.PrimArray
getLowResTimerManagerSystem.LowResTimer
getMaskingStateSystem.IO.Exception
getMaskingState#Foreign.PrimArray
getSizeofMutableByteArray#Foreign.PrimArray
getSpark#Foreign.PrimArray
getUVManagerSystem.IO.UV.Manager
geWord#Foreign.PrimArray
gtAddr#Foreign.PrimArray
gtChar#Foreign.PrimArray
gtFloat#Foreign.PrimArray
gtWord#Foreign.PrimArray
-------------------------------------------------------------------------------- /docs/stdio/doc-index-H.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index - H)

stdio-0.1.0.0: Standard Input and Output for Haskell

Index - H

handleSystem.IO.Exception
handleJustSystem.IO.Exception
Handler 
1 (Data Constructor)System.IO.Exception
2 (Type/Class)System.IO.Exception
HardwareFault 
1 (Type/Class)System.IO.Exception
2 (Data Constructor)System.IO.Exception
HasCallStackGHC.Stack.Compat, System.IO.Exception
head 
1 (Function)Data.Vector
2 (Function)Data.Text
HeapOverflowSystem.IO.Exception
hs_uv_async_wake_initSystem.IO.UV.Internal
hs_uv_dirent_allocSystem.IO.UV.Internal
hs_uv_dirent_freeSystem.IO.UV.Internal
hs_uv_filenoSystem.IO.UV.Internal
hs_uv_handle_allocSystem.IO.UV.Internal
hs_uv_handle_closeSystem.IO.UV.Internal
hs_uv_handle_freeSystem.IO.UV.Internal
hs_uv_loop_closeSystem.IO.UV.Internal
hs_uv_loop_initSystem.IO.UV.Internal
hs_uv_loop_resizeSystem.IO.UV.Internal
hs_uv_read_startSystem.IO.UV.Stream
hs_uv_req_allocSystem.IO.UV.Internal
hs_uv_req_freeSystem.IO.UV.Internal
hs_uv_tcp_connectSystem.IO.UV.Internal
hs_uv_tcp_openSystem.IO.UV.Internal
hs_uv_timer_wake_startSystem.IO.UV.Internal
hs_uv_writeSystem.IO.UV.Stream
htonlSystem.IO.Net.SockAddr, System.IO.Net
htonsSystem.IO.Net.SockAddr, System.IO.Net
-------------------------------------------------------------------------------- /docs/stdio/doc-index-K.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index - K)

stdio-0.1.0.0: Standard Input and Output for Haskell

Index - K

killThread#Foreign.PrimArray
-------------------------------------------------------------------------------- /docs/stdio/doc-index-L.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index - L)

stdio-0.1.0.0: Standard Input and Output for Haskell

Index - L

labelThread#Foreign.PrimArray
last 
1 (Function)Data.Vector
2 (Function)Data.Text
LE 
1 (Type/Class)Data.Binary
2 (Data Constructor)Data.Binary
leAddr#Foreign.PrimArray
leChar#Foreign.PrimArray
leFloat#Foreign.PrimArray
length 
1 (Function)Data.Vector
2 (Function)Data.Text
leWord#Foreign.PrimArray
logDouble#Foreign.PrimArray
logFloat#Foreign.PrimArray
LossOfPrecisionSystem.IO.Exception
LowResTimerManagerSystem.LowResTimer
lowResTimerManagerCapabilitiesChangedSystem.LowResTimer
ltAddr#Foreign.PrimArray
ltChar#Foreign.PrimArray
ltFloat#Foreign.PrimArray
ltWord#Foreign.PrimArray
-------------------------------------------------------------------------------- /docs/stdio/doc-index-O.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index - O)

stdio-0.1.0.0: Standard Input and Output for Haskell

Index - O

OneShotActionData.Builder
oneShotActionData.Builder
onExceptionSystem.IO.Exception
or#Foreign.PrimArray
ord#Foreign.PrimArray
orI#Foreign.PrimArray
OtherError 
1 (Type/Class)System.IO.Exception
2 (Data Constructor)System.IO.Exception
OutputSystem.IO.Buffered
outputBufferSystem.IO.Buffered
OverflowSystem.IO.Exception
-------------------------------------------------------------------------------- /docs/stdio/doc-index-Q.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index - Q)

stdio-0.1.0.0: Standard Input and Output for Haskell

Index - Q

quotInt#Foreign.PrimArray
quotInt16X16#Foreign.PrimArray
quotInt16X32#Foreign.PrimArray
quotInt16X8#Foreign.PrimArray
quotInt32X16#Foreign.PrimArray
quotInt32X4#Foreign.PrimArray
quotInt32X8#Foreign.PrimArray
quotInt64X2#Foreign.PrimArray
quotInt64X4#Foreign.PrimArray
quotInt64X8#Foreign.PrimArray
quotInt8X16#Foreign.PrimArray
quotInt8X32#Foreign.PrimArray
quotInt8X64#Foreign.PrimArray
quotRemInt#Foreign.PrimArray
quotRemWord#Foreign.PrimArray
quotRemWord2#Foreign.PrimArray
quotWord#Foreign.PrimArray
quotWord16X16#Foreign.PrimArray
quotWord16X32#Foreign.PrimArray
quotWord16X8#Foreign.PrimArray
quotWord32X16#Foreign.PrimArray
quotWord32X4#Foreign.PrimArray
quotWord32X8#Foreign.PrimArray
quotWord64X2#Foreign.PrimArray
quotWord64X4#Foreign.PrimArray
quotWord64X8#Foreign.PrimArray
quotWord8X16#Foreign.PrimArray
quotWord8X32#Foreign.PrimArray
quotWord8X64#Foreign.PrimArray
-------------------------------------------------------------------------------- /docs/stdio/doc-index-V.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index - V)

stdio-0.1.0.0: Standard Input and Output for Haskell

Index - V

validateCharData.Text.UTF8Codec
validateChar#Data.Text.UTF8Codec
validateUTF8Data.Text
validateUTF8_Data.Text
vASCIIData.Vector
VecData.Vector
VecPatData.Vector
Vector 
1 (Type/Class)Data.Vector
2 (Data Constructor)Data.Vector
vectorLiteralData.Primitive.PrimArrayQ
Void#Foreign.PrimArray
void#Foreign.PrimArray
vW16Data.Vector
-------------------------------------------------------------------------------- /docs/stdio/doc-index-X.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index - X)

stdio-0.1.0.0: Standard Input and Output for Haskell

Index - X

xor#Foreign.PrimArray
xorI#Foreign.PrimArray
-------------------------------------------------------------------------------- /docs/stdio/doc-index-Y.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index - Y)

stdio-0.1.0.0: Standard Input and Output for Haskell

Index - Y

yield#Foreign.PrimArray
-------------------------------------------------------------------------------- /docs/stdio/doc-index.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell (Index)

stdio-0.1.0.0: Standard Input and Output for Haskell

-------------------------------------------------------------------------------- /docs/stdio/haddock-util.js: -------------------------------------------------------------------------------- 1 | // Haddock JavaScript utilities 2 | 3 | var rspace = /\s\s+/g, 4 | rtrim = /^\s+|\s+$/g; 5 | 6 | function spaced(s) { return (" " + s + " ").replace(rspace, " "); } 7 | function trim(s) { return s.replace(rtrim, ""); } 8 | 9 | function hasClass(elem, value) { 10 | var className = spaced(elem.className || ""); 11 | return className.indexOf( " " + value + " " ) >= 0; 12 | } 13 | 14 | function addClass(elem, value) { 15 | var className = spaced(elem.className || ""); 16 | if ( className.indexOf( " " + value + " " ) < 0 ) { 17 | elem.className = trim(className + " " + value); 18 | } 19 | } 20 | 21 | function removeClass(elem, value) { 22 | var className = spaced(elem.className || ""); 23 | className = className.replace(" " + value + " ", " "); 24 | elem.className = trim(className); 25 | } 26 | 27 | function toggleClass(elem, valueOn, valueOff, bool) { 28 | if (bool == null) { bool = ! hasClass(elem, valueOn); } 29 | if (bool) { 30 | removeClass(elem, valueOff); 31 | addClass(elem, valueOn); 32 | } 33 | else { 34 | removeClass(elem, valueOn); 35 | addClass(elem, valueOff); 36 | } 37 | return bool; 38 | } 39 | 40 | 41 | function makeClassToggle(valueOn, valueOff) 42 | { 43 | return function(elem, bool) { 44 | return toggleClass(elem, valueOn, valueOff, bool); 45 | } 46 | } 47 | 48 | toggleShow = makeClassToggle("show", "hide"); 49 | toggleCollapser = makeClassToggle("collapser", "expander"); 50 | 51 | function toggleSection(id) 52 | { 53 | var b = toggleShow(document.getElementById("section." + id)); 54 | toggleCollapser(document.getElementById("control." + id), b); 55 | rememberCollapsed(id); 56 | return b; 57 | } 58 | 59 | var collapsed = {}; 60 | function rememberCollapsed(id) 61 | { 62 | if(collapsed[id]) 63 | delete collapsed[id] 64 | else 65 | collapsed[id] = true; 66 | 67 | var sections = []; 68 | for(var i in collapsed) 69 | { 70 | if(collapsed.hasOwnProperty(i)) 71 | sections.push(i); 72 | } 73 | // cookie specific to this page; don't use setCookie which sets path=/ 74 | document.cookie = "collapsed=" + escape(sections.join('+')); 75 | } 76 | 77 | function restoreCollapsed() 78 | { 79 | var cookie = getCookie("collapsed"); 80 | if(!cookie) 81 | return; 82 | 83 | var ids = cookie.split('+'); 84 | for(var i in ids) 85 | { 86 | if(document.getElementById("section." + ids[i])) 87 | toggleSection(ids[i]); 88 | } 89 | } 90 | 91 | function setCookie(name, value) { 92 | document.cookie = name + "=" + escape(value) + ";path=/;"; 93 | } 94 | 95 | function clearCookie(name) { 96 | document.cookie = name + "=;path=/;expires=Thu, 01-Jan-1970 00:00:01 GMT;"; 97 | } 98 | 99 | function getCookie(name) { 100 | var nameEQ = name + "="; 101 | var ca = document.cookie.split(';'); 102 | for(var i=0;i < ca.length;i++) { 103 | var c = ca[i]; 104 | while (c.charAt(0)==' ') c = c.substring(1,c.length); 105 | if (c.indexOf(nameEQ) == 0) { 106 | return unescape(c.substring(nameEQ.length,c.length)); 107 | } 108 | } 109 | return null; 110 | } 111 | 112 | function addMenuItem(html) { 113 | var menu = document.getElementById("page-menu"); 114 | if (menu) { 115 | var btn = menu.firstChild.cloneNode(false); 116 | btn.innerHTML = html; 117 | menu.appendChild(btn); 118 | } 119 | } 120 | 121 | function styles() { 122 | var i, a, es = document.getElementsByTagName("link"), rs = []; 123 | for (i = 0; a = es[i]; i++) { 124 | if(a.rel.indexOf("style") != -1 && a.title) { 125 | rs.push(a); 126 | } 127 | } 128 | return rs; 129 | } 130 | 131 | function addStyleMenu() { 132 | var as = styles(); 133 | var i, a, btns = ""; 134 | for(i=0; a = as[i]; i++) { 135 | btns += "
  • " 137 | + a.title + "
    • " 138 | } 139 | if (as.length > 1) { 140 | var h = "
    " 141 | + "Style ▾" 142 | + "
      " + btns + "
    " 143 | + "
    "; 144 | addMenuItem(h); 145 | } 146 | } 147 | 148 | function setActiveStyleSheet(title) { 149 | var as = styles(); 150 | var i, a, found; 151 | for(i=0; a = as[i]; i++) { 152 | a.disabled = true; 153 | // need to do this always, some browsers are edge triggered 154 | if(a.title == title) { 155 | found = a; 156 | } 157 | } 158 | if (found) { 159 | found.disabled = false; 160 | setCookie("haddock-style", title); 161 | } 162 | else { 163 | as[0].disabled = false; 164 | clearCookie("haddock-style"); 165 | } 166 | styleMenu(false); 167 | } 168 | 169 | function resetStyle() { 170 | var s = getCookie("haddock-style"); 171 | if (s) setActiveStyleSheet(s); 172 | } 173 | 174 | 175 | function styleMenu(show) { 176 | var m = document.getElementById('style-menu'); 177 | if (m) toggleShow(m, show); 178 | } 179 | 180 | 181 | function pageLoad() { 182 | addStyleMenu(); 183 | resetStyle(); 184 | restoreCollapsed(); 185 | } 186 | 187 | -------------------------------------------------------------------------------- /docs/stdio/hslogo-16.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/winterland1989/stdio/122d9ff5381e66a87b5d810a23b8d4ec82f5b5c4/docs/stdio/hslogo-16.png -------------------------------------------------------------------------------- /docs/stdio/index.html: -------------------------------------------------------------------------------- 1 | stdio-0.1.0.0: Standard Input and Output for Haskell

    stdio-0.1.0.0: Standard Input and Output for Haskell

    stdio-0.1.0.0: Standard Input and Output for Haskell

    Standard Input and Output for Haskell.

    Signatures

    Modules

    -------------------------------------------------------------------------------- /docs/stdio/minus.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/winterland1989/stdio/122d9ff5381e66a87b5d810a23b8d4ec82f5b5c4/docs/stdio/minus.gif -------------------------------------------------------------------------------- /docs/stdio/plus.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/winterland1989/stdio/122d9ff5381e66a87b5d810a23b8d4ec82f5b5c4/docs/stdio/plus.gif -------------------------------------------------------------------------------- /docs/stdio/stdio.haddock: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/winterland1989/stdio/122d9ff5381e66a87b5d810a23b8d4ec82f5b5c4/docs/stdio/stdio.haddock -------------------------------------------------------------------------------- /docs/stdio/synopsis.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/winterland1989/stdio/122d9ff5381e66a87b5d810a23b8d4ec82f5b5c4/docs/stdio/synopsis.png -------------------------------------------------------------------------------- /img/banner.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/winterland1989/stdio/122d9ff5381e66a87b5d810a23b8d4ec82f5b5c4/img/banner.png -------------------------------------------------------------------------------- /include/hs_uv.h: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int uv_translate_sys_error(int sys_errno); 4 | 5 | typedef struct { 6 | size_t event_counter; 7 | size_t* event_queue; 8 | char** buffer_table; 9 | ssize_t* buffer_size_table; 10 | } hs_loop_data; 11 | 12 | uv_loop_t* hs_uv_loop_init(size_t siz); 13 | uv_loop_t* hs_uv_loop_resize(uv_loop_t* loop, size_t siz); 14 | void hs_uv_loop_close(uv_loop_t* loop); 15 | 16 | uv_handle_t* hs_uv_handle_alloc(uv_handle_type typ); 17 | void hs_uv_handle_free(uv_handle_t* handle); 18 | void hs_uv_handle_close(uv_handle_t* handle); 19 | 20 | uv_handle_t* hs_uv_req_alloc(uv_req_type typ); 21 | void hs_uv_req_free(uv_req_t* req); 22 | 23 | int hs_uv_read_start(uv_stream_t* stream); 24 | int hs_uv_write(uv_write_t* req, uv_stream_t* handle); 25 | 26 | 27 | int hs_uv_tcp_open(uv_tcp_t* handle, int sock); 28 | int hs_uv_tcp_connect(uv_connect_t* req, uv_tcp_t* handle, const struct sockaddr* addr); 29 | 30 | 31 | int hs_uv_timer_wake_start(uv_timer_t* handle, uint64_t timeout); 32 | int hs_uv_async_wake_init(uv_loop_t* loop, uv_async_t* async); 33 | 34 | 35 | 36 | #if defined(_WIN32) 37 | enum { 38 | UV__SIGNAL_ONE_SHOT = 0x80000, /* On signal reception remove sighandler */ 39 | UV__HANDLE_INTERNAL = 0x8000, 40 | UV__HANDLE_ACTIVE = 0x4000, 41 | UV__HANDLE_REF = 0x2000, 42 | UV__HANDLE_CLOSING = 0 /* no-op on unix */ 43 | }; 44 | #define UV_HANDLE_TCP_SINGLE_ACCEPT 0x08000000 45 | #define UV_HANDLE_TCP_ACCEPT_STATE_CHANGING 0x10000000 46 | extern unsigned int uv_simultaneous_server_accepts; 47 | void uv_tcp_queue_accept(uv_tcp_t* handle, uv_tcp_accept_t* req); 48 | int32_t hs_uv_tcp_accept(uv_tcp_t* server); 49 | int32_t hs_uv_pipe_accept(uv_pipe_t* server); 50 | #else 51 | ssize_t read(int fd, void *buf, size_t count); 52 | int uv__close(int fd); /* preserves errno */ 53 | int uv__stream_open(uv_stream_t* stream, int fd, int flags); 54 | typedef struct uv__stream_queued_fds_s uv__stream_queued_fds_t; 55 | void uv__io_start(uv_loop_t* loop, uv__io_t* w, unsigned int events); 56 | struct uv__stream_queued_fds_s { 57 | unsigned int size; 58 | unsigned int offset; 59 | int fds[1]; 60 | }; 61 | void uv__free(void* ptr); 62 | 63 | /* handle flags */ 64 | enum { 65 | UV_CLOSING = 0x01, /* uv_close() called but not finished. */ 66 | UV_CLOSED = 0x02, /* close(2) finished. */ 67 | UV_STREAM_READING = 0x04, /* uv_read_start() called. */ 68 | UV_STREAM_SHUTTING = 0x08, /* uv_shutdown() called but not complete. */ 69 | UV_STREAM_SHUT = 0x10, /* Write side closed. */ 70 | UV_STREAM_READABLE = 0x20, /* The stream is readable */ 71 | UV_STREAM_WRITABLE = 0x40, /* The stream is writable */ 72 | UV_STREAM_BLOCKING = 0x80, /* Synchronous writes. */ 73 | UV_STREAM_READ_PARTIAL = 0x100, /* read(2) read less than requested. */ 74 | UV_STREAM_READ_EOF = 0x200, /* read(2) read EOF. */ 75 | UV_TCP_NODELAY = 0x400, /* Disable Nagle. */ 76 | UV_TCP_KEEPALIVE = 0x800, /* Turn on keep-alive. */ 77 | UV_TCP_SINGLE_ACCEPT = 0x1000, /* Only accept() when idle. */ 78 | UV_HANDLE_IPV6 = 0x10000, /* Handle is bound to a IPv6 socket. */ 79 | UV_UDP_PROCESSING = 0x20000, /* Handle is running the send callback queue. */ 80 | UV_HANDLE_BOUND = 0x40000 /* Handle is bound to an address and port */ 81 | }; 82 | 83 | #if defined(__sun) 84 | # include 85 | # include 86 | #endif /* __sun */ 87 | 88 | #if defined(_AIX) 89 | # define reqevents events 90 | # define rtnevents revents 91 | # include 92 | #else 93 | # include 94 | #endif /* _AIX */ 95 | 96 | #endif 97 | 98 | //////////////////////////////////////////////////////////////////////////////// 99 | 100 | void hs_uv_fs_callback(uv_fs_t* req); 101 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-10.4 2 | 3 | packages: 4 | - . 5 | - bench\tcp 6 | - bench\timers 7 | -------------------------------------------------------------------------------- /stdio.cabal: -------------------------------------------------------------------------------- 1 | -- Initial stdio.cabal generated by cabal init. For further documentation, 2 | -- see http://haskell.org/cabal/users-guide/ 3 | 4 | name: stdio 5 | version: 0.1.0.0 6 | synopsis: Standard Input and Output for Haskell 7 | description: Standard Input and Output for Haskell. 8 | license: BSD3 9 | license-file: LICENSE 10 | author: winter 11 | maintainer: drkoster@qq.com 12 | -- copyright: 13 | category: Data 14 | build-type: Simple 15 | cabal-version: >=1.10 16 | homepage: https://github.com/winterland1989/stdio 17 | bug-reports: https://github.com/winterland1989/stdio/issues 18 | 19 | extra-source-files: ChangeLog.md 20 | include/hs_uv.h 21 | cbits/hs_uv.c 22 | cbits/bytes.c 23 | 24 | source-repository head 25 | type: git 26 | location: git://github.com/winterland1989/stdio.git 27 | 28 | 29 | library 30 | exposed-modules: Data.Primitive.PrimArray 31 | Data.Primitive.PrimArrayQ 32 | Data.Primitive.BitTwiddle 33 | Data.Vector 34 | Data.Array 35 | Data.Array.Checked 36 | Data.CBytes 37 | Data.Parser 38 | Data.Text 39 | Data.Text.UTF8Codec 40 | 41 | Data.Binary 42 | Data.Builder 43 | 44 | Foreign.PrimArray 45 | GHC.Stack.Compat 46 | 47 | System.IO.Exception 48 | System.IO.Buffered 49 | -- System.IO.File 50 | -- System.IO.Handle 51 | System.LowResTimer 52 | 53 | 54 | System.IO.UV.Exception 55 | System.IO.UV.Stream 56 | System.IO.UV.Internal 57 | System.IO.UV.Manager 58 | 59 | System.IO.TTY 60 | -- System.IO.Log 61 | 62 | System.IO.FileSystem 63 | System.IO.FileSystem.Slow 64 | 65 | System.IO.Net 66 | System.IO.Net.SockAddr 67 | 68 | -- System.IO.Socket 69 | -- System.IO.Socket.Address 70 | -- System.IO.Socket.Base 71 | -- System.IO.Socket.TCP 72 | -- System.IO.Socket.Exception 73 | 74 | 75 | 76 | -- other-modules: System.IO.UV 77 | -- other-extensions: 78 | 79 | build-depends: base >=4.7 && <5.0 80 | , ghc-prim >= 0.4 81 | , primitive >= 0.6.2 82 | , deepseq 83 | , template-haskell 84 | , unboxed-ref >= 0.4 85 | 86 | include-dirs: include 87 | includes: hs_uv.h 88 | install-includes: hs_uv.h 89 | c-sources: cbits/bytes.c 90 | cbits/hs_uv.c 91 | 92 | if os(windows) 93 | c-sources: 94 | -- Note: The c-sources list is taken from libuv's Makefile.mingw, needs to be 95 | -- updated when we bump up libuv's version. 96 | third_party/libuv/src/fs-poll.c 97 | , third_party/libuv/src/inet.c 98 | , third_party/libuv/src/threadpool.c 99 | , third_party/libuv/src/uv-common.c 100 | , third_party/libuv/src/version.c 101 | , third_party/libuv/src/win/async.c 102 | , third_party/libuv/src/win/core.c 103 | , third_party/libuv/src/win/detect-wakeup.c 104 | , third_party/libuv/src/win/dl.c 105 | , third_party/libuv/src/win/error.c 106 | , third_party/libuv/src/win/fs-event.c 107 | , third_party/libuv/src/win/fs.c 108 | , third_party/libuv/src/win/getaddrinfo.c 109 | , third_party/libuv/src/win/getnameinfo.c 110 | , third_party/libuv/src/win/handle.c 111 | , third_party/libuv/src/win/loop-watcher.c 112 | , third_party/libuv/src/win/pipe.c 113 | , third_party/libuv/src/win/poll.c 114 | , third_party/libuv/src/win/process-stdio.c 115 | , third_party/libuv/src/win/process.c 116 | , third_party/libuv/src/win/req.c 117 | , third_party/libuv/src/win/signal.c 118 | , third_party/libuv/src/win/stream.c 119 | , third_party/libuv/src/win/tcp.c 120 | , third_party/libuv/src/win/thread.c 121 | , third_party/libuv/src/win/timer.c 122 | , third_party/libuv/src/win/tty.c 123 | , third_party/libuv/src/win/udp.c 124 | , third_party/libuv/src/win/util.c 125 | , third_party/libuv/src/win/winapi.c 126 | , third_party/libuv/src/win/winsock.c 127 | cc-options: -Wall -Wextra -Wno-unused-parameter -Wstrict-prototypes -DWIN32_LEAN_AND_MEAN -D_WIN32_WINNT=0x0600 -Ithird_party/libuv/src -Ithird_party/libuv/src/win 128 | cpp-options: -DWIN32_LEAN_AND_MEAN -D_WIN32_WINNT=0x0600 129 | include-dirs: third_party/libuv/include 130 | -- The C runtime dependencies are imposed by libuv. 131 | extra-libraries: psapi, Iphlpapi, userenv 132 | else 133 | extra-libraries: uv 134 | 135 | -- hs-source-dirs: 136 | default-language: Haskell2010 137 | build-tools: hsc2hs 138 | -- ghc-options: -Wall 139 | 140 | benchmark bench 141 | build-depends: base 142 | , binary 143 | , deepseq 144 | , bytestring 145 | , vector 146 | , text 147 | , stdio 148 | , ghc-prim 149 | , primitive 150 | , criterion == 1.1.* 151 | , stm 152 | 153 | default-language: Haskell2010 154 | hs-source-dirs: bench 155 | main-is: Main.hs 156 | type: exitcode-stdio-1.0 157 | ghc-options: -O2 -threaded 158 | 159 | 160 | test-suite test 161 | type: exitcode-stdio-1.0 162 | main-is: Main.hs 163 | -- other-modules: 164 | hs-source-dirs: test 165 | build-depends: stdio 166 | , base 167 | , tasty == 0.11.* 168 | , tasty-hunit 169 | , tasty-quickcheck 170 | , tasty-hunit 171 | , QuickCheck >= 2.10 172 | , async 173 | , unboxed-ref 174 | 175 | 176 | ghc-options: -threaded 177 | default-language: Haskell2010 178 | 179 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Main where 4 | 5 | import Test.Tasty 6 | import Property.Vector 7 | import Property.Text 8 | import Unit.LowResTimer 9 | 10 | main :: IO () 11 | main = defaultMain $ testGroup "stdio tests" [ 12 | propertyVector 13 | , propertyText 14 | , unitLowResTimer 15 | 16 | 17 | ] 18 | 19 | -------------------------------------------------------------------------------- /test/Property/Text.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Property.Text where 5 | 6 | import Test.Tasty 7 | import Test.Tasty.QuickCheck 8 | import Test.QuickCheck.Property 9 | import Test.QuickCheck.Function 10 | import Test.QuickCheck 11 | import qualified Data.Vector as V 12 | import qualified Data.Text as T 13 | import Data.Char 14 | import qualified Data.List as List 15 | 16 | propertyText :: TestTree 17 | propertyText = testGroup "text property" [ 18 | testProperty "text eq === string eq" . property $ \ xs ys -> 19 | (T.pack xs == T.pack ys) === (xs == ys) 20 | 21 | , testProperty "text compare === string compare" . property $ \ xs ys -> 22 | (T.pack xs `compare` T.pack ys) === (xs `compare` ys) 23 | 24 | , testProperty "unpack . pack === id" . property $ \ xs -> 25 | (T.unpack) (T.pack xs) === xs 26 | 27 | 28 | ] 29 | -------------------------------------------------------------------------------- /test/Unit/LowResTimer.hs: -------------------------------------------------------------------------------- 1 | module Unit.LowResTimer where 2 | 3 | import Test.Tasty 4 | import Test.Tasty.HUnit 5 | import Control.Concurrent.Async 6 | import Control.Concurrent 7 | import Control.Monad 8 | import Data.IORef.Unboxed 9 | import System.LowResTimer 10 | 11 | unitLowResTimer :: TestTree 12 | unitLowResTimer = testGroup "low resolution timers" [ 13 | testCase "timers registration should not be missed" $ do 14 | c <- newCounter 0 15 | replicateConcurrently_ 10000 $ do 16 | forM_ [1..10] $ \ i -> do 17 | registerLowResTimer i (void $ atomicAddCounter c 1) 18 | 19 | lrtm <- getLowResTimerManager 20 | running <- isLowResTimerManagerRunning lrtm 21 | assertEqual "timer manager should start" True running 22 | 23 | threadDelay 1200000 -- make sure all timers are fired 24 | c' <- readIORefU c 25 | assertEqual "timers registration counter" 100000 c' 26 | 27 | threadDelay 100000 -- another 0.1s 28 | 29 | lrtm <- getLowResTimerManager 30 | running <- isLowResTimerManagerRunning lrtm 31 | assertEqual "timer manager should stopped" False running 32 | 33 | , testCase "debounce sh" $ do 34 | c <- newCounter 0 35 | debouncedAdd <- debounce 1 (atomicAddCounter c 1) 36 | forkIO . replicateM_ 10000 $ do 37 | debouncedAdd 38 | threadDelay 500 39 | threadDelay 1000000 -- wait 1s here 40 | c' <- readIORefU c 41 | assertBool "debounced add" (5 <= c' && c' <= 6) 42 | ] 43 | -------------------------------------------------------------------------------- /test/Unit/Text.hs: -------------------------------------------------------------------------------- 1 | module Unit.Text where 2 | 3 | import Test.Tasty.HUnit 4 | 5 | unitText :: TestTree 6 | unitText = testGroup "vector property" [ 7 | ] 8 | --------------------------------------------------------------------------------