├── std-data ├── README.md ├── test │ ├── Spec.hs │ └── Std │ │ └── Data │ │ ├── JSON │ │ ├── ValueSpec.hs │ │ └── BaseSpec.hs │ │ ├── Vector │ │ ├── FlatSetSpec.hs │ │ └── FlatMapSpec.hs │ │ ├── Text │ │ ├── SearchSpec.hs │ │ └── BaseSpec.hs │ │ ├── CBytesSpec.hs │ │ ├── TextBuilderSpec.hs │ │ ├── LEONSpec.hs │ │ └── Parser │ │ ├── BaseSpec.hs │ │ └── NumericSpec.hs ├── ChangeLog.md ├── Std │ └── Data │ │ ├── PrimSTRef.hs │ │ ├── Generics │ │ └── Utils.hs │ │ ├── Builder │ │ ├── Time.hs │ │ └── Numeric │ │ │ └── DigitTable.hs │ │ ├── PrimSTRef │ │ └── Base.hs │ │ ├── Builder.hs │ │ ├── Parser.hs │ │ ├── PrimArray │ │ └── Cast.hs │ │ ├── Text.hs │ │ ├── Vector │ │ └── QQ.hs │ │ ├── JSON │ │ └── Builder.hs │ │ ├── Text │ │ └── Search.hs │ │ ├── Vector.hs │ │ └── Array │ │ └── Compound.hs ├── LICENSE ├── include │ ├── dtoa.h │ ├── bytes.h │ └── text.h └── cbits │ └── bytes.c ├── std-io ├── README.md ├── test │ ├── Spec.hs │ └── Std │ │ └── IO │ │ ├── LowResTimerSpec.hs │ │ ├── UDPSpec.hs │ │ ├── ResourceSpec.hs │ │ ├── FileSystemSpec.hs │ │ └── FileSystemTSpec.hs ├── ChangeLog.md ├── Std │ └── IO │ │ ├── TTY.hs │ │ └── Pipe.hs ├── LICENSE └── cbits │ └── hs_uv_udp.c ├── docs ├── _config.yml ├── io-manager-flow.png ├── io-manager-thread-structure.png ├── A High-Performance Multicore IO Manager Based on libuv (Experience Report).pdf └── index.md ├── bench ├── json │ ├── Setup.hs │ ├── CHANGELOG.md │ ├── Options.hs │ ├── json-data │ │ ├── dates.json │ │ ├── dates-fract.json │ │ ├── twitter1.json │ │ ├── example.json │ │ ├── integers.json │ │ └── twitter10.json │ ├── node.js │ ├── Auto │ │ ├── T │ │ │ ├── BigSum.hs │ │ │ ├── BigProduct.hs │ │ │ ├── BigRecord.hs │ │ │ └── D.hs │ │ └── G │ │ │ ├── BigSum.hs │ │ │ ├── BigProduct.hs │ │ │ ├── BigRecord.hs │ │ │ └── D.hs │ ├── Aeson.hs │ ├── AesonLazy.hs │ ├── Stdio.hs │ ├── LICENSE │ ├── bench-aeson.py │ ├── bench-stdio.py │ ├── bench-aeson-lazy.py │ ├── json-bench.cabal │ └── AutoCompare.hs ├── tcp │ ├── Setup.hs │ ├── result-summary.pdf │ ├── ChangeLog.md │ ├── nodejs │ │ └── main.js │ ├── tcp.cabal │ ├── LICENSE │ ├── LibUV.hs │ ├── MIO.hs │ ├── golang │ │ └── main.go │ └── README.md ├── parser │ ├── Setup.hs │ ├── ChangeLog.md │ ├── parser.cabal │ ├── LICENSE │ └── Main.hs ├── timers │ ├── Setup.hs │ ├── ChangeLog.md │ ├── LowResTimer.hs │ ├── SystemTimer.hs │ ├── README.md │ ├── timers.cabal │ └── LICENSE └── data │ ├── Main.hs │ ├── data.cabal │ ├── BitTwiddle.hs │ ├── Text.hs │ └── Builder.hs ├── stack.yaml ├── .gitignore ├── .gitmodules ├── appveyor.yml ├── .travis.yml └── README.md /std-data/README.md: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /std-io/README.md: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /docs/_config.yml: -------------------------------------------------------------------------------- 1 | theme: jekyll-theme-dinky -------------------------------------------------------------------------------- /bench/json/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bench/tcp/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bench/parser/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bench/timers/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /std-io/test/Spec.hs: -------------------------------------------------------------------------------- 1 | -- file test/Spec.hs 2 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 3 | -------------------------------------------------------------------------------- /docs/io-manager-flow.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ZHaskell/stdio/HEAD/docs/io-manager-flow.png -------------------------------------------------------------------------------- /std-data/test/Spec.hs: -------------------------------------------------------------------------------- 1 | -- file test/Spec.hs 2 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 3 | -------------------------------------------------------------------------------- /bench/tcp/result-summary.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ZHaskell/stdio/HEAD/bench/tcp/result-summary.pdf -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.20 2 | 3 | extra-deps: [] 4 | 5 | packages: 6 | - std-data 7 | - std-io 8 | -------------------------------------------------------------------------------- /docs/io-manager-thread-structure.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ZHaskell/stdio/HEAD/docs/io-manager-thread-structure.png -------------------------------------------------------------------------------- /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/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/json/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for json-bench 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /bench/parser/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for parser 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /bench/json/Options.hs: -------------------------------------------------------------------------------- 1 | module Options (opts) where 2 | 3 | import Data.Aeson.Types 4 | 5 | opts :: Options 6 | opts = defaultOptions 7 | { sumEncoding = ObjectWithSingleField 8 | } 9 | 10 | -------------------------------------------------------------------------------- /docs/A High-Performance Multicore IO Manager Based on libuv (Experience Report).pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ZHaskell/stdio/HEAD/docs/A High-Performance Multicore IO Manager Based on libuv (Experience Report).pdf -------------------------------------------------------------------------------- /bench/json/json-data/dates.json: -------------------------------------------------------------------------------- 1 | ["2015-02-02T09:10:11Z","2015-02-03T09:10:11+0000","2014-01-02T09:10:11Z","2014-01-03T02:09:12-0300","2013-05-06T07:08:09Z","2015-02-02T09:10:11+04:00","2015-02-03T09:10:11Z","2014-01-02T09:10:11-11:45","2014-01-03T02:09:12Z","2013-05-06T07:08:09+0000"] 2 | -------------------------------------------------------------------------------- /bench/json/json-data/dates-fract.json: -------------------------------------------------------------------------------- 1 | ["2015-02-02T09:10:11.123Z","2015-02-03T09:10:11.000+0000","2014-01-02T09:10:11.333Z","2014-01-03T02:09:12.000-02:00","2013-05-06T07:08:09.444Z","2015-02-02T09:10:11.66+03:00","2015-02-03T09:10:11.66Z","2014-01-02T09:10:11.66-1200","2014-01-03T02:09:12.66Z","2013-05-06T07:08:09.66+00:00"] 2 | -------------------------------------------------------------------------------- /.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 | bench/testbench/** 25 | .ghc.environment.* 26 | cabal.project.* 27 | .vscode/** 28 | uploadDocs.sh 29 | -------------------------------------------------------------------------------- /bench/timers/LowResTimer.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Concurrent.STM 4 | import Control.Concurrent 5 | import Control.Monad 6 | import Std.IO.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/json/node.js: -------------------------------------------------------------------------------- 1 | // use this script like this: node node.js 1000 ./json-data/buffer-builder.json 2 | 3 | fs = require('fs') 4 | 5 | var count = process.argv[2] 6 | var filenames = process.argv.splice(3) 7 | 8 | var start = new Date().getTime() 9 | 10 | filenames.map(function(filename){ 11 | for (var n=0; n < parseInt(count); n++){ 12 | var inp = fs.readFileSync(filename) 13 | JSON.parse(inp) 14 | } 15 | }); 16 | 17 | end = new Date().getTime() 18 | console.log(count, ' good, ', (end - start)/1000, 's') 19 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "third_party/libuv"] 2 | path = std-io/third_party/libuv 3 | url = https://github.com/haskell-stdio/libuv.git 4 | [submodule "third_party/utf8rewind"] 5 | path = std-data/third_party/utf8rewind 6 | url = https://github.com/haskell-stdio/utf8rewind.git 7 | [submodule "third_party/fastvalidate-utf-8"] 8 | path = std-data/third_party/fastvalidate-utf-8 9 | url = https://github.com/lemire/fastvalidate-utf-8.git 10 | [submodule "third_party/zlib"] 11 | path = third_party/zlib 12 | url = git@github.com:haskell-stdio/zlib.git 13 | -------------------------------------------------------------------------------- /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/json/Auto/T/BigSum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Auto.T.BigSum where 4 | 5 | import Control.DeepSeq 6 | import Data.Aeson.TH 7 | import Options 8 | 9 | data BigSum = F01 | F02 | F03 | F04 | F05 10 | | F06 | F07 | F08 | F09 | F10 11 | | F11 | F12 | F13 | F14 | F15 12 | | F16 | F17 | F18 | F19 | F20 13 | | F21 | F22 | F23 | F24 | F25 14 | deriving (Show, Eq) 15 | 16 | instance NFData BigSum where 17 | rnf a = a `seq` () 18 | 19 | deriveJSON opts ''BigSum 20 | 21 | bigSum :: BigSum 22 | bigSum = F25 23 | -------------------------------------------------------------------------------- /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/json/Auto/T/BigProduct.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Auto.T.BigProduct where 4 | 5 | import Control.DeepSeq 6 | import Data.Aeson.TH 7 | import Options 8 | 9 | data BigProduct = BigProduct 10 | !Int !Int !Int !Int !Int 11 | !Int !Int !Int !Int !Int 12 | !Int !Int !Int !Int !Int 13 | !Int !Int !Int !Int !Int 14 | !Int !Int !Int !Int !Int 15 | deriving (Show, Eq) 16 | 17 | instance NFData BigProduct where 18 | rnf a = a `seq` () 19 | 20 | deriveJSON opts ''BigProduct 21 | 22 | bigProduct :: BigProduct 23 | bigProduct = BigProduct 1 2 3 4 5 24 | 6 7 8 9 10 25 | 11 12 13 14 15 26 | 16 17 18 19 20 27 | 21 22 23 24 25 28 | -------------------------------------------------------------------------------- /std-data/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for stdio 2 | 3 | ## 0.1.1.0 -- 2019-02-19 4 | 5 | * Add LEON, a little endian first serialization/deserialization module. 6 | * Use pkg-config to find libuv by default, which can be turned off via cabal flag no-pkg-config 7 | * Export `Result` constructor in `Std.Data.Parser` module. 8 | 9 | ## 0.2.0.0 --2019-05-15 10 | 11 | * Add UDP module. 12 | * Add JSON module. 13 | * Add `ToText` class to `TextBuilder` module. 14 | * Improve numeric builders by using FFI code. 15 | * Change `readParser` 's type in `Std.IO.Buffered` module to directly return parsing result. 16 | * Add `FlatMap/FlatSet/FlatIntMap/FlatIntSet` module. 17 | * Fix a bug of `Parser` 's `Alternative` instance. 18 | * Fix a bug of `PrimVector` 's `QuasiQuoter`. 19 | -------------------------------------------------------------------------------- /std-io/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for stdio 2 | 3 | ## 0.1.1.0 -- 2019-02-19 4 | 5 | * Add LEON, a little endian first serialization/deserialization module. 6 | * Use pkg-config to find libuv by default, which can be turned off via cabal flag no-pkg-config 7 | * Export `Result` constructor in `Std.Data.Parser` module. 8 | 9 | ## 0.2.0.0 --2019-05-15 10 | 11 | * Add UDP module. 12 | * Add JSON module. 13 | * Add `ToText` class to `TextBuilder` module. 14 | * Improve numeric builders by using FFI code. 15 | * Change `readParser` 's type in `Std.IO.Buffered` module to directly return parsing result. 16 | * Add `FlatMap/FlatSet/FlatIntMap/FlatIntSet` module. 17 | * Fix a bug of `Parser` 's `Alternative` instance. 18 | * Fix a bug of `PrimVector` 's `QuasiQuoter`. 19 | -------------------------------------------------------------------------------- /std-data/Std/Data/PrimSTRef.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Std.Data.PrimSTRef 3 | Copyright : (c) Dong Han 2017~2019 4 | License : BSD-style 5 | 6 | Maintainer : winterland1989@gmail.com 7 | Stability : experimental 8 | Portability : portable 9 | 10 | This module provide fast unboxed references for ST monad. Unboxed reference is implemented using single cell MutableByteArray s to eliminate indirection overhead which MutVar# s a carry, on the otherhand unboxed reference only support limited type(instances of Prim class). 11 | -} 12 | 13 | module Std.Data.PrimSTRef 14 | ( -- * Unboxed ST references 15 | PrimSTRef 16 | , newPrimSTRef 17 | , readPrimSTRef 18 | , writePrimSTRef 19 | , modifyPrimSTRef 20 | ) where 21 | 22 | import Std.Data.PrimSTRef.Base 23 | -------------------------------------------------------------------------------- /bench/json/json-data/twitter1.json: -------------------------------------------------------------------------------- 1 | {"results":[{"from_user_id_str":"80430860","profile_image_url":"http://a2.twimg.com/profile_images/536455139/icon32_normal.png","created_at":"Wed, 26 Jan 2011 07:07:02 +0000","from_user":"kazu_yamamoto","id_str":"30159761706061824","metadata":{"result_type":"recent"},"to_user_id":null,"text":"Haskell Server Pages \u3063\u3066\u3001\u307e\u3060\u7d9a\u3044\u3066\u3044\u305f\u306e\u304b\uff01","id":30159761706061824,"from_user_id":80430860,"geo":null,"iso_language_code":"no","to_user_id_str":null,"source":"<a href="http://twitter.com/">web</a>"}],"max_id":30159761706061824,"since_id":0,"refresh_url":"?since_id=30159761706061824&q=haskell","next_page":"?page=2&max_id=30159761706061824&rpp=1&q=haskell","results_per_page":1,"page":1,"completed_in":0.012606,"since_id_str":"0","max_id_str":"30159761706061824","query":"haskell"} 2 | -------------------------------------------------------------------------------- /bench/json/Auto/G/BigSum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | 4 | module Auto.G.BigSum where 5 | 6 | import Control.DeepSeq 7 | import Data.Aeson 8 | import qualified Std.Data.JSON.Base as JSON 9 | import GHC.Generics (Generic) 10 | import Options 11 | 12 | data BigSum = F01 | F02 | F03 | F04 | F05 13 | | F06 | F07 | F08 | F09 | F10 14 | | F11 | F12 | F13 | F14 | F15 15 | | F16 | F17 | F18 | F19 | F20 16 | | F21 | F22 | F23 | F24 | F25 17 | deriving (Show, Eq, Generic, JSON.FromValue, JSON.ToValue, JSON.EncodeJSON) 18 | 19 | instance NFData BigSum where 20 | rnf a = a `seq` () 21 | 22 | instance ToJSON BigSum where 23 | toJSON = genericToJSON opts 24 | toEncoding = genericToEncoding opts 25 | 26 | instance FromJSON BigSum where 27 | parseJSON = genericParseJSON opts 28 | 29 | bigSum :: BigSum 30 | bigSum = F25 31 | -------------------------------------------------------------------------------- /std-data/test/Std/Data/JSON/ValueSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Std.Data.JSON.ValueSpec where 5 | 6 | import qualified Data.List as L 7 | import Data.Word 8 | import Data.Int 9 | import GHC.Float 10 | import Data.Word8 (toLower, toUpper) 11 | import qualified Std.Data.Builder as B 12 | import Test.QuickCheck 13 | import Test.QuickCheck.Function 14 | import Test.QuickCheck.Property 15 | import Test.Hspec 16 | import Test.Hspec.QuickCheck 17 | import qualified Std.Data.JSON.Value as JSON 18 | import qualified Std.Data.JSON.Builder as JSONB 19 | 20 | 21 | spec :: Spec 22 | spec = describe "JSON" $ do -- large size will generate too huge JSON document 23 | prop "value roundtrip" $ \ v -> 24 | Right v === JSON.parseValue' (B.buildBytes (JSONB.value v)) 25 | -------------------------------------------------------------------------------- /bench/json/Auto/T/BigRecord.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Auto.T.BigRecord where 4 | 5 | import Control.DeepSeq 6 | import Data.Aeson.TH 7 | import Options 8 | 9 | data BigRecord = BigRecord 10 | { field01 :: !Int, field02 :: !Int, field03 :: !Int, field04 :: !Int, field05 :: !Int 11 | , field06 :: !Int, field07 :: !Int, field08 :: !Int, field09 :: !Int, field10 :: !Int 12 | , field11 :: !Int, field12 :: !Int, field13 :: !Int, field14 :: !Int, field15 :: !Int 13 | , field16 :: !Int, field17 :: !Int, field18 :: !Int, field19 :: !Int, field20 :: !Int 14 | , field21 :: !Int, field22 :: !Int, field23 :: !Int, field24 :: !Int, field25 :: !Int 15 | } deriving (Show, Eq) 16 | 17 | instance NFData BigRecord where 18 | rnf a = a `seq` () 19 | 20 | deriveJSON opts ''BigRecord 21 | 22 | bigRecord :: BigRecord 23 | bigRecord = BigRecord 1 2 3 4 5 24 | 6 7 8 9 10 25 | 11 12 13 14 15 26 | 16 17 18 19 20 27 | 21 22 23 24 25 28 | -------------------------------------------------------------------------------- /bench/data/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module Main (main) where 7 | 8 | import Control.DeepSeq 9 | import Criterion.Main 10 | import qualified Data.ByteString as B 11 | import qualified Data.List as List 12 | import qualified Data.Vector.Unboxed as VU 13 | import Data.Word 14 | import System.IO (readFile) 15 | import qualified Data.Text as T 16 | import qualified Std.Data.Text as S 17 | import qualified Std.Data.Vector as V 18 | 19 | import Builder 20 | import Bytes 21 | import Text 22 | import BitTwiddle 23 | 24 | main :: IO () 25 | main = do 26 | str <- readFile "./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 | -------------------------------------------------------------------------------- /std-io/Std/IO/TTY.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE ExistentialQuantification #-} 6 | 7 | {-| 8 | Module : Std.IO.TTY 9 | Description : TTY devices 10 | Copyright : (c) Dong Han, 2018 11 | License : BSD 12 | Maintainer : winterland1989@gmail.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 Std.IO.TTY( 21 | initTTYStream 22 | ) where 23 | 24 | import Std.IO.Exception 25 | import Std.IO.Resource 26 | import Std.IO.UV.FFI 27 | import Std.IO.UV.Manager 28 | import System.IO.Unsafe 29 | 30 | initTTYStream :: HasCallStack => UVFD -> UVManager -> Resource UVStream 31 | initTTYStream fd = initUVStream (\ loop handle -> 32 | throwUVIfMinus_ (uv_tty_init loop handle (fromIntegral fd))) 33 | 34 | -- TODO: Add TTY related functions 35 | -------------------------------------------------------------------------------- /bench/json/Auto/G/BigProduct.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | 4 | module Auto.G.BigProduct where 5 | 6 | import Control.DeepSeq 7 | import Data.Aeson 8 | import qualified Std.Data.JSON.Base as JSON 9 | import GHC.Generics (Generic) 10 | import Options 11 | 12 | data BigProduct = BigProduct 13 | !Int !Int !Int !Int !Int 14 | !Int !Int !Int !Int !Int 15 | !Int !Int !Int !Int !Int 16 | !Int !Int !Int !Int !Int 17 | !Int !Int !Int !Int !Int 18 | deriving (Show, Eq, Generic, JSON.FromValue, JSON.ToValue, JSON.EncodeJSON) 19 | 20 | instance NFData BigProduct where 21 | rnf a = a `seq` () 22 | 23 | instance ToJSON BigProduct where 24 | toJSON = genericToJSON opts 25 | toEncoding = genericToEncoding opts 26 | 27 | instance FromJSON BigProduct where 28 | parseJSON = genericParseJSON opts 29 | 30 | bigProduct :: BigProduct 31 | bigProduct = BigProduct 1 2 3 4 5 32 | 6 7 8 9 10 33 | 11 12 13 14 15 34 | 16 17 18 19 20 35 | 21 22 23 24 25 36 | -------------------------------------------------------------------------------- /bench/json/Auto/T/D.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Auto.T.D where 4 | 5 | import Control.DeepSeq 6 | import Data.Aeson.TH 7 | import Options 8 | 9 | data D a = Nullary 10 | | Unary Int 11 | | Product String Char a 12 | | Record { testOne :: Double 13 | , testTwo :: Bool 14 | , testThree :: D a 15 | } 16 | deriving (Show, Eq) 17 | 18 | instance NFData a => NFData (D a) where 19 | rnf Nullary = () 20 | rnf (Unary n) = rnf n 21 | rnf (Product s c x) = s `deepseq` c `deepseq` rnf x 22 | rnf (Record a b y) = a `deepseq` b `deepseq` rnf y 23 | 24 | deriveJSON opts ''D 25 | 26 | type T = D (D (D ())) 27 | 28 | d :: T 29 | d = Record 30 | { testOne = 1234.56789 31 | , testTwo = True 32 | , testThree = Product "Hello World!" 'a' 33 | Record 34 | { testOne = 9876.54321 35 | , testTwo = False 36 | , testThree = Product "Yeehaa!!!" '\n' Nullary 37 | } 38 | } 39 | -------------------------------------------------------------------------------- /bench/parser/parser.cabal: -------------------------------------------------------------------------------- 1 | -- Initial parser.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: parser 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: winterland1989 11 | maintainer: winterland1989@gmail.com 12 | -- copyright: 13 | category: Development 14 | build-type: Simple 15 | extra-source-files: ChangeLog.md 16 | cabal-version: >=1.10 17 | 18 | executable parser 19 | main-is: Main.hs 20 | -- other-modules: 21 | other-extensions: OverloadedStrings, BangPatterns 22 | build-depends: base, 23 | stdio, 24 | deepseq, 25 | bytestring, 26 | cereal, 27 | binary, 28 | store-core, 29 | attoparsec 30 | 31 | hs-source-dirs: . 32 | default-language: Haskell2010 33 | ghc-options: -O 34 | -------------------------------------------------------------------------------- /bench/data/data.cabal: -------------------------------------------------------------------------------- 1 | name: data 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | license: BSD3 6 | license-file: LICENSE 7 | author: handong 8 | maintainer: handong@xiaomi.com 9 | -- copyright: 10 | category: Concurrency 11 | build-type: Simple 12 | extra-source-files: ChangeLog.md 13 | cabal-version: >=1.10 14 | 15 | executable data 16 | main-is: Main.hs 17 | -- other-modules: 18 | -- other-extensions: 19 | build-depends: base >=4.12 && <5.0 20 | , binary 21 | , std-data 22 | , deepseq 23 | , bytestring 24 | , vector 25 | , text 26 | , ghc-prim 27 | , primitive 28 | , criterion 29 | , stm 30 | 31 | hs-source-dirs: ./ 32 | ghc-options: -O2 -threaded 33 | default-language: Haskell2010 34 | if os(windows) 35 | buildable: False 36 | -------------------------------------------------------------------------------- /std-data/Std/Data/Generics/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE MagicHash #-} 6 | {-# LANGUAGE KindSignatures #-} 7 | {-# LANGUAGE DataKinds #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE FunctionalDependencies #-} 12 | 13 | 14 | module Std.Data.Generics.Utils 15 | ( ProductSize(..) 16 | , productSize 17 | ) where 18 | 19 | import GHC.Generics 20 | import GHC.TypeNats 21 | import GHC.Exts (Proxy#, proxy#) 22 | 23 | -- | type class for calculating product size. 24 | class KnownNat (PSize f) => ProductSize (f :: * -> *) where 25 | type PSize f :: Nat 26 | 27 | instance ProductSize (S1 s a) where 28 | type PSize (S1 s a) = 1 29 | instance (KnownNat (PSize a + PSize b), ProductSize a, ProductSize b) => ProductSize (a :*: b) where 30 | type PSize (a :*: b) = PSize a + PSize b 31 | 32 | productSize :: forall f. KnownNat (PSize f) => Proxy# f -> Int 33 | productSize _ = fromIntegral (natVal' (proxy# :: Proxy# (PSize f))) 34 | -------------------------------------------------------------------------------- /bench/tcp/nodejs/main.js: -------------------------------------------------------------------------------- 1 | var net = require('net'); 2 | var cluster = require('cluster'); 3 | var numCPUs = 4; 4 | var port = 8888; 5 | 6 | if ( process.env.PORT ) { port = process.env.PORT } 7 | if ( process.env.CPU_NUM ) { numCPUs = process.env.CPU_NUM } 8 | 9 | if (cluster.isMaster) { 10 | for (var i = 0; i < numCPUs; i++) { 11 | cluster.fork(); 12 | } 13 | } else { 14 | var server = net.createServer(function(socket) { 15 | socket.on('data', function(data){ 16 | socket.write(respond); 17 | }) 18 | }); 19 | server.listen(port); 20 | } 21 | 22 | var respond = 23 | 24 | "HTTP/1.1 200 OK\r\n\ 25 | Content-Type: text/html; charset=UTF-8\r\n\ 26 | Content-Length: 500\r\n\ 27 | Connection: Keep-Alive\r\n\r\n\ 28 | 00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" 29 | 30 | 31 | 32 | -------------------------------------------------------------------------------- /bench/json/Aeson.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Main (main) where 5 | 6 | import Data.Aeson 7 | import Control.Monad 8 | import Data.Attoparsec.ByteString (IResult(..), parseWith) 9 | import Data.Time.Clock 10 | import System.Environment (getArgs) 11 | import System.IO 12 | import qualified Data.ByteString as B 13 | 14 | main :: IO () 15 | main = do 16 | (bs:cnt:args) <- getArgs 17 | let count = read cnt :: Int 18 | blkSize = read bs 19 | forM_ args $ \arg -> withFile arg ReadMode $ \h -> do 20 | putStrLn $ arg ++ ":" 21 | start <- getCurrentTime 22 | let loop !good !bad 23 | | good+bad >= count = return (good, bad) 24 | | otherwise = do 25 | hSeek h AbsoluteSeek 0 26 | let refill = B.hGet h blkSize 27 | result <- parseWith refill json' =<< refill 28 | case result of 29 | Done _ _ -> loop (good+1) bad 30 | _ -> loop good (bad+1) 31 | (good, _) <- loop 0 0 32 | delta <- flip diffUTCTime start `fmap` getCurrentTime 33 | putStrLn $ " " ++ show good ++ " good, " ++ show delta 34 | let rate = fromIntegral count / realToFrac delta :: Double 35 | putStrLn $ " " ++ show (round rate :: Int) ++ " per second" 36 | -------------------------------------------------------------------------------- /bench/json/AesonLazy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Main (main) where 5 | 6 | import Data.Aeson 7 | import Control.Monad 8 | import Data.Attoparsec.ByteString (IResult(..), parseWith) 9 | import Data.Time.Clock 10 | import System.Environment (getArgs) 11 | import System.IO 12 | import qualified Data.ByteString as B 13 | 14 | main :: IO () 15 | main = do 16 | (bs:cnt:args) <- getArgs 17 | let count = read cnt :: Int 18 | blkSize = read bs 19 | forM_ args $ \arg -> withFile arg ReadMode $ \h -> do 20 | putStrLn $ arg ++ ":" 21 | start <- getCurrentTime 22 | let loop !good !bad 23 | | good+bad >= count = return (good, bad) 24 | | otherwise = do 25 | hSeek h AbsoluteSeek 0 26 | let refill = B.hGet h blkSize 27 | result <- parseWith refill json =<< refill 28 | case result of 29 | Done _ _ -> loop (good+1) bad 30 | _ -> loop good (bad+1) 31 | (good, _) <- loop 0 0 32 | delta <- flip diffUTCTime start `fmap` getCurrentTime 33 | putStrLn $ " " ++ show good ++ " good, " ++ show delta 34 | let rate = fromIntegral count / realToFrac delta :: Double 35 | putStrLn $ " " ++ show (round rate :: Int) ++ " per second" 36 | -------------------------------------------------------------------------------- /std-data/test/Std/Data/Vector/FlatSetSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Std.Data.Vector.FlatSetSpec where 5 | 6 | import qualified Data.List as List 7 | import Data.Word 8 | import qualified Std.Data.Vector as V 9 | import qualified Std.Data.Vector.FlatSet as FS 10 | import Test.QuickCheck 11 | import Test.QuickCheck.Function 12 | import Test.QuickCheck.Property 13 | import Test.Hspec 14 | import Test.Hspec.QuickCheck 15 | 16 | type FMS = FS.FlatSet String 17 | 18 | spec :: Spec 19 | spec = do 20 | describe "flatset-semigroup-monoid" $ do 21 | prop "flatset monoid unit law" $ \ (m :: FMS) -> 22 | (m <> FS.empty) === m 23 | prop "flatset monoid unit law" $ \ (m :: FMS) -> 24 | (FS.empty <> m) === m 25 | prop "flatset semigroup associativity low" $ \ (m1 :: FMS) m2 m3 -> 26 | (m1 <> m2) <> m3 === m1 <> (m2 <> m3) 27 | 28 | describe "flatset insert elem roundtrip" $ do 29 | prop "flatset insert elem roundtrip" $ \ (m :: FMS) v -> 30 | FS.elem v (FS.insert v m) === True 31 | 32 | describe "flatset delete elem" $ do 33 | prop "flatset delete elem" $ \ (m :: FMS) v -> 34 | FS.elem v (FS.delete v m) === False 35 | -------------------------------------------------------------------------------- /bench/json/Auto/G/BigRecord.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | 4 | module Auto.G.BigRecord where 5 | 6 | import Control.DeepSeq 7 | import Data.Aeson 8 | import qualified Std.Data.JSON.Base as JSON 9 | import GHC.Generics (Generic) 10 | import Options 11 | 12 | data BigRecord = BigRecord 13 | { field01 :: !Int, field02 :: !Int, field03 :: !Int, field04 :: !Int, field05 :: !Int 14 | , field06 :: !Int, field07 :: !Int, field08 :: !Int, field09 :: !Int, field10 :: !Int 15 | , field11 :: !Int, field12 :: !Int, field13 :: !Int, field14 :: !Int, field15 :: !Int 16 | , field16 :: !Int, field17 :: !Int, field18 :: !Int, field19 :: !Int, field20 :: !Int 17 | , field21 :: !Int, field22 :: !Int, field23 :: !Int, field24 :: !Int, field25 :: !Int 18 | } deriving (Show, Eq, Generic, JSON.FromValue, JSON.ToValue, JSON.EncodeJSON) 19 | 20 | instance NFData BigRecord where 21 | rnf a = a `seq` () 22 | 23 | instance ToJSON BigRecord where 24 | toJSON = genericToJSON opts 25 | toEncoding = genericToEncoding opts 26 | 27 | instance FromJSON BigRecord where 28 | parseJSON = genericParseJSON opts 29 | 30 | bigRecord :: BigRecord 31 | bigRecord = BigRecord 1 2 3 4 5 32 | 6 7 8 9 10 33 | 11 12 13 14 15 34 | 16 17 18 19 20 35 | 21 22 23 24 25 36 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | environment: 2 | matrix: 3 | - CABALVER: 2.4.1.0 4 | GHCVER: 8.6.2 5 | 6 | install: 7 | # Using '-y' and 'refreshenv' as a workaround to: 8 | # https://github.com/haskell/cabal/issues/3687 9 | - choco install -y ghc --version %GHCVER% 10 | - choco install -y cabal --version %CABALVER% 11 | - refreshenv 12 | # See http://help.appveyor.com/discussions/problems/6312-curl-command-not-found#comment_42195491 13 | # NB: Do this after refreshenv, otherwise it will be clobbered! 14 | - set PATH=%AppData%\cabal\bin;C:\Program Files\Git\mingw64\bin;%PATH% 15 | # TODO: remove --insecure, this is to workaround haskell.org 16 | # failing to send intermediate cert; see https://github.com/haskell/cabal/pull/4172 17 | # - 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 18 | # - 7z x -bd cabal.zip 19 | - ghc --version 20 | - cabal --version 21 | - cabal update 22 | - cabal install hspec-discover 23 | - refreshenv 24 | 25 | build_script: 26 | - git submodule update --init 27 | - cabal new-build # this builds all libraries and executables (including tests/benchmarks) 28 | - cabal new-run test 29 | - cabal check 30 | - cabal sdist # tests that a source-distribution can be generated 31 | -------------------------------------------------------------------------------- /bench/data/BitTwiddle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE MagicHash #-} 4 | 5 | module BitTwiddle (bitTwiddle) where 6 | 7 | import Criterion.Main 8 | import qualified Data.ByteString as BS 9 | import qualified Std.Data.Vector.Base as V 10 | import Control.DeepSeq 11 | import Control.Monad 12 | import Data.Word 13 | import GHC.Prim 14 | import GHC.Types 15 | import Data.Primitive.ByteArray 16 | import Data.Primitive.PrimArray 17 | import qualified Std.Data.PrimArray.BitTwiddle as T 18 | import qualified Data.List as List 19 | 20 | bytestring1000000 :: BS.ByteString 21 | bytestring1000000 = BS.replicate 1000000 0 22 | 23 | bytes1000000 :: V.Bytes 24 | bytes1000000 = V.replicate 1000000 0 25 | 26 | 27 | bitTwiddle :: [Benchmark] 28 | bitTwiddle = 29 | [ bgroup "memchr 1000000" memchr 30 | , bgroup "memcnt 1000000" memchrReverse 31 | ] 32 | 33 | memchr :: [Benchmark] 34 | memchr = 35 | [ bench "bytestring/elemIndex" $ nf (BS.elemIndex 1) bytestring1000000 36 | , bench "bit-twiddling/memchr" $ nf (\ (V.PrimVector ba s l) -> T.memchr ba 1 s l) bytes1000000 37 | ] 38 | 39 | memchrReverse :: [Benchmark] 40 | memchrReverse = 41 | [ bench "bytestring/elemIndexReverse" $ nf (BS.elemIndexEnd 1) bytestring1000000 42 | , bench "bit-twiddling/memchrReverse" $ nf (\ (V.PrimVector ba s l) -> T.memchrReverse ba 1 s l) bytes1000000 43 | ] 44 | -------------------------------------------------------------------------------- /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.12 && <5.0 24 | , stm 25 | , stdio 26 | hs-source-dirs: ./ 27 | ghc-options: -O2 -threaded -with-rtsopts=-N4 28 | default-language: Haskell2010 29 | 30 | 31 | executable system-timer 32 | main-is: SystemTimer.hs 33 | -- other-modules: 34 | -- other-extensions: 35 | build-depends: base >=4.12 && <5.0 36 | , stm 37 | hs-source-dirs: ./ 38 | ghc-options: -O2 -threaded -with-rtsopts=-N4 39 | default-language: Haskell2010 40 | if os(windows) 41 | buildable: False 42 | -------------------------------------------------------------------------------- /bench/json/Stdio.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Main (main) where 5 | 6 | import Std.Data.JSON.Value as JSON 7 | import Std.IO.Buffered 8 | import Std.IO.FileSystem 9 | import Std.IO.Resource 10 | import Std.Data.CBytes as CBytes 11 | import Control.Monad 12 | import Data.Time.Clock 13 | import Std.Data.Vector.Base as V 14 | import System.Environment (getArgs) 15 | import System.IO 16 | 17 | main :: IO () 18 | main = do 19 | (bs:cnt:args) <- getArgs 20 | let count = read cnt :: Int 21 | blkSize = read bs :: Int 22 | forM_ args $ \arg -> withResource (initUVFile (CBytes.pack arg) O_RDWR DEFAULT_MODE) $ \ f -> do 23 | putStrLn $ arg ++ ":" 24 | start <- getCurrentTime 25 | r <- newUVFileReader f 0 26 | bio <- newBufferedInput r blkSize 27 | let loop !good !bad 28 | | good+bad >= count = return (good, bad) 29 | | otherwise = do 30 | peekUVFileReader r 0 31 | (_, result) <- parseValueChunks (readBuffer bio) =<< (readBuffer bio) 32 | case result of 33 | Right _ -> loop (good+1) bad 34 | _ -> loop good (bad+1) 35 | (good, _) <- loop 0 0 36 | delta <- flip diffUTCTime start `fmap` getCurrentTime 37 | putStrLn $ " " ++ show good ++ " good, " ++ show delta 38 | let rate = fromIntegral count / realToFrac delta :: Double 39 | putStrLn $ " " ++ show (round rate :: Int) ++ " per second" 40 | -------------------------------------------------------------------------------- /std-data/Std/Data/Builder/Time.hs: -------------------------------------------------------------------------------- 1 | W.I.P 2 | 3 | 4 | -- | Formats a time in ISO 8601, with up to 12 second decimals. 5 | -- %%Y-%m-%dT%%H:%M:%S%Q. 6 | formatISO8601 :: UTCTime -> String 7 | 8 | 9 | formatISO8601Millis :: UTCTime -> String 10 | 11 | Formats a time in ISO 8601 with up to millisecond precision and trailing zeros. The format is precisely: 12 | 13 | YYYY-MM-DDTHH:mm:ss.sssZ 14 | formatISO8601Micros :: UTCTime -> String 15 | 16 | Formats a time in ISO 8601 with up to microsecond precision and trailing zeros. The format is precisely: 17 | 18 | YYYY-MM-DDTHH:mm:ss.ssssssZ 19 | formatISO8601Nanos :: UTCTime -> String 20 | 21 | Formats a time in ISO 8601 with up to nanosecond precision and trailing zeros. The format is precisely: 22 | 23 | YYYY-MM-DDTHH:mm:ss.sssssssssZ 24 | formatISO8601Picos :: UTCTime -> String 25 | 26 | Formats a time in ISO 8601 with up to picosecond precision and trailing zeros. The format is precisely: 27 | 28 | YYYY-MM-DDTHH:mm:ss.ssssssssssssZ 29 | formatISO8601Javascript :: UTCTime -> String 30 | 31 | Formats a time like JavaScript's new Date().toISOString() as specified by Mozilla: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/toISOString 32 | 33 | This is an alias for formatISO8601Millis. 34 | 35 | parseISO8601 :: String -> Maybe UTCTime 36 | 37 | Parses an ISO 8601 string. 38 | 39 | Leading and trailing whitespace is accepted. See parseTimeM from the time package for more details. 40 | -------------------------------------------------------------------------------- /bench/json/Auto/G/D.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | 4 | module Auto.G.D where 5 | 6 | import Control.DeepSeq 7 | import Data.Aeson 8 | import qualified Std.Data.JSON.Base as JSON 9 | import GHC.Generics (Generic) 10 | import Options 11 | 12 | data D a = Nullary 13 | | Unary Int 14 | | Product String Char a 15 | | Record { testOne :: Double 16 | , testTwo :: Bool 17 | , testThree :: D a 18 | } 19 | deriving (Show, Eq, Generic, JSON.FromValue, JSON.ToValue, JSON.EncodeJSON) 20 | 21 | instance NFData a => NFData (D a) where 22 | rnf Nullary = () 23 | rnf (Unary n) = rnf n 24 | rnf (Product s c x) = s `deepseq` c `deepseq` rnf x 25 | rnf (Record a b y) = a `deepseq` b `deepseq` rnf y 26 | 27 | instance ToJSON a => ToJSON (D a) where 28 | toJSON = genericToJSON opts 29 | toEncoding = genericToEncoding opts 30 | 31 | instance FromJSON a => FromJSON (D a) where 32 | parseJSON = genericParseJSON opts 33 | 34 | type T = D (D (D ())) 35 | 36 | d :: T 37 | d = Record 38 | { testOne = 1234.56789 39 | , testTwo = True 40 | , testThree = Product "Hello World!" 'a' 41 | Record 42 | { testOne = 9876.54321 43 | , testTwo = False 44 | , testThree = Product "Yeehaa!!!" '\n' Nullary 45 | } 46 | } 47 | -------------------------------------------------------------------------------- /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-extensions: 21 | 22 | build-depends: base >=4.9 && <5.0 23 | , bytestring 24 | , stdio 25 | , unboxed-ref 26 | 27 | hs-source-dirs: ./ 28 | ghc-options: -O2 -threaded -rtsopts -eventlog -with-rtsopts=-N 29 | default-language: Haskell2010 30 | 31 | 32 | executable mio 33 | main-is: MIO.hs 34 | -- other-modules: 35 | -- other-extensions: 36 | build-depends: base >=4.9 && <5.0 37 | , network 38 | , stm 39 | , async 40 | , bytestring 41 | , unboxed-ref 42 | 43 | hs-source-dirs: ./ 44 | ghc-options: -O2 -threaded -rtsopts -eventlog -with-rtsopts=-N 45 | default-language: Haskell2010 46 | -------------------------------------------------------------------------------- /std-data/test/Std/Data/Vector/FlatMapSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Std.Data.Vector.FlatMapSpec where 5 | 6 | import qualified Data.List as List 7 | import Data.Word 8 | import qualified Std.Data.Vector as V 9 | import qualified Std.Data.Vector.FlatMap as FM 10 | import Test.QuickCheck 11 | import Test.QuickCheck.Function 12 | import Test.QuickCheck.Property 13 | import Test.Hspec 14 | import Test.Hspec.QuickCheck 15 | 16 | type FMS = FM.FlatMap String String 17 | 18 | spec :: Spec 19 | spec = do 20 | describe "flatmap-semigroup-monoid" $ do 21 | prop "flatmap monoid unit law" $ \ (m :: FMS) -> 22 | (m <> FM.empty) === m 23 | prop "flatmap monoid unit law" $ \ (m :: FMS) -> 24 | (FM.empty <> m) === m 25 | prop "flatmap semigroup associativity low" $ \ (m1 :: FMS) m2 m3 -> 26 | (m1 <> m2) <> m3 === m1 <> (m2 <> m3) 27 | 28 | describe "flatmap insert lookup roundtrip" $ do 29 | prop "flatmap insert lookup roundtrip" $ \ (m :: FMS) k v -> 30 | FM.lookup k (FM.insert k v m) === Just v 31 | 32 | describe "flatmap delete lookup" $ do 33 | prop "flatmap delete lookup" $ \ (m :: FMS) k -> 34 | FM.lookup k (FM.delete k m) === Nothing 35 | 36 | describe "flatmap adjust lookup roundtrip" $ do 37 | prop "flatmap adjust lookup roundtrip" $ \ (m :: FMS) k (Fun _ f) -> 38 | FM.lookup k (FM.adjust' f k m) === f `fmap` FM.lookup k m 39 | -------------------------------------------------------------------------------- /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/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 | -------------------------------------------------------------------------------- /std-io/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017-2019, Haskell Stdio Team 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/json/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, winterland1989 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 winterland1989 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/parser/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, winterland1989 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 winterland1989 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 | -------------------------------------------------------------------------------- /std-data/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017-2019, Haskell Stdio Team 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 | -------------------------------------------------------------------------------- /std-data/Std/Data/PrimSTRef/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | 3 | {-| 4 | Module : Std.Data.PrimSTRef.Base 5 | Copyright : (c) Dong Han 2017~2019 6 | License : BSD-style 7 | 8 | Maintainer : winterland1989@gmail.com 9 | Stability : experimental 10 | Portability : portable 11 | 12 | Internal module for 'Std.Data.PrimSTRef' and 'Std.Data.PrimIORef'. 13 | -} 14 | 15 | 16 | module Std.Data.PrimSTRef.Base 17 | ( -- * Unboxed ST references 18 | PrimSTRef(..) 19 | , newPrimSTRef 20 | , readPrimSTRef 21 | , writePrimSTRef 22 | , modifyPrimSTRef 23 | ) where 24 | 25 | import Data.Primitive.Types 26 | import Data.Primitive.ByteArray 27 | import GHC.ST 28 | import GHC.Types 29 | 30 | -- | A mutable variable in the ST monad which can hold an instance of 'Prim'. 31 | -- 32 | newtype PrimSTRef s a = PrimSTRef (MutableByteArray s) 33 | 34 | -- | Build a new 'PrimSTRef' 35 | -- 36 | newPrimSTRef :: Prim a => a -> ST s (PrimSTRef s a) 37 | newPrimSTRef x = do 38 | mba <- newByteArray (I# (sizeOf# x)) 39 | writeByteArray mba 0 x 40 | return (PrimSTRef mba) 41 | {-# INLINE newPrimSTRef #-} 42 | 43 | -- | Read the value of an 'PrimSTRef' 44 | -- 45 | readPrimSTRef :: Prim a => PrimSTRef s a -> ST s a 46 | readPrimSTRef (PrimSTRef mba) = readByteArray mba 0 47 | {-# INLINE readPrimSTRef #-} 48 | 49 | -- | Write a new value into an 'PrimSTRef' 50 | -- 51 | writePrimSTRef :: Prim a => PrimSTRef s a -> a -> ST s () 52 | writePrimSTRef (PrimSTRef mba) x = writeByteArray mba 0 x 53 | {-# INLINE writePrimSTRef #-} 54 | 55 | -- | Mutate the contents of an 'PrimSTRef'. 56 | -- 57 | -- Unboxed reference is always strict on the value it hold. 58 | -- 59 | modifyPrimSTRef :: Prim a => PrimSTRef s a -> (a -> a) -> ST s () 60 | modifyPrimSTRef ref f = readPrimSTRef ref >>= writePrimSTRef ref . f 61 | {-# INLINE modifyPrimSTRef #-} 62 | -------------------------------------------------------------------------------- /bench/tcp/LibUV.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Main where 5 | 6 | import Std.IO.TCP 7 | import Std.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 Std.IO.Exception 15 | import Data.IORef.Unboxed 16 | import System.Environment 17 | import Text.Read (readMaybe) 18 | 19 | main :: IO () 20 | main = do 21 | portStr <- lookupEnv "PORT" 22 | let port = maybe 8888 id (readMaybe =<< portStr) 23 | let conf = defaultServerConfig{ 24 | serverAddr = SockAddrInet port inetAny 25 | , serverWorker = \ uvs -> do 26 | recvbuf <- mallocPlainForeignPtrBytes 2048 -- we reuse buffer as golang does, 27 | -- since node use slab, which is in fact a memory pool 28 | -- this is more fair 29 | 30 | -- do not print ECONNRESET for fairness 31 | catch (echo uvs recvbuf) (\ (e::SomeException) -> return ()) 32 | } 33 | 34 | startServer conf 35 | where 36 | echo uvs recvbuf = loop 37 | where 38 | loop = do 39 | r <- withForeignPtr recvbuf $ \ p -> do 40 | readInput uvs p 2048 41 | when (r /= 0) $ do 42 | withForeignPtr sendbuffp $ \ p -> writeOutput uvs p l 43 | loop 44 | 45 | (B.PS sendbuffp _ l) = 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 | 53 | 54 | 55 | -------------------------------------------------------------------------------- /std-io/Std/IO/Pipe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE ExistentialQuantification #-} 6 | 7 | {-| 8 | Module : Std.IO.Pipe 9 | Description : Named pipe/Unix domain servers and clients 10 | Copyright : (c) Dong Han, 2018 11 | License : BSD 12 | Maintainer : winterland1989@gmail.com 13 | Stability : experimental 14 | Portability : non-portable 15 | 16 | This module provides an API for creating 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 | initPipeStream :: HasCallStack => UVManager -> Resource UVStream 28 | initPipeStream = initUVStream uV_NAMED_PIPE (\ loop handle -> 29 | throwUVIfMinus_ (uv_pipe_init loop handle 0)) 30 | -------------------------------------------------------------------------------- /std-data/include/dtoa.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2017-2019 Dong Han 3 | * 4 | * All rights reserved. 5 | * 6 | * Redistribution and use in source and binary forms, with or without 7 | * modification, are permitted provided that the following conditions 8 | * are met: 9 | * 1. Redistributions of source code must retain the above copyright 10 | * notice, this list of conditions and the following disclaimer. 11 | * 2. Redistributions in binary form must reproduce the above copyright 12 | * notice, this list of conditions and the following disclaimer in the 13 | * documentation and/or other materials provided with the distribution. 14 | * 3. Neither the names of the authors or the names of any contributors 15 | * may be used to endorse or promote products derived from this software 16 | * without specific prior written permission. 17 | * 18 | * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 19 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 22 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 24 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 25 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 26 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 27 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 28 | * SUCH DAMAGE. 29 | */ 30 | 31 | #include 32 | 33 | HsInt grisu3(double v, char *buffer, HsInt *length, HsInt *d_exp); 34 | HsInt grisu3_sp(float v, char *buffer, HsInt *length, HsInt *d_exp); 35 | HsInt c_int_dec (uint64_t x, HsInt sign, HsInt width, uint8_t pad, char* ba, HsInt off); 36 | -------------------------------------------------------------------------------- /std-data/test/Std/Data/Text/SearchSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Std.Data.Text.SearchSpec where 5 | 6 | import qualified Data.List as List 7 | import Data.Word 8 | import qualified Std.Data.Text.Base as T 9 | import qualified Std.Data.Text.Extra as T 10 | import qualified Std.Data.Text.Search as T 11 | import Test.QuickCheck 12 | import Test.QuickCheck.Function 13 | import Test.QuickCheck.Property 14 | import Test.Hspec 15 | import Test.Hspec.QuickCheck 16 | 17 | spec :: Spec 18 | spec = describe "text-search" $ do 19 | 20 | describe "T.elem == List.elem" $ do 21 | prop "T.elem = List.elem" $ \ y x -> 22 | (T.elem y $ T.pack x) === (List.elem y $ x) 23 | 24 | describe "snd . T.find == List.find" $ do 25 | prop "snd .T.find = List.find" $ \ (Fun _ y) x -> 26 | (case T.find y . T.pack $ x of (_, _, c) -> c) === (List.find y $ x) 27 | 28 | describe "T.find" $ do 29 | prop "T.find = maybe List.length List.findIndexOrEnd" $ \ (Fun _ y) x -> 30 | (case T.find y . T.pack $ x of (i,_,_) -> i) === 31 | (maybe (List.length x) id $ List.findIndex y x) 32 | 33 | describe "T.findR" $ do 34 | prop "T.find = findR . reverse" $ \ (Fun _ y) x -> 35 | (case T.find y . T.pack $ x of (i,_,_) -> i) === 36 | (case T.findR y . T.reverse $ T.pack x of (i,_,_) -> i) 37 | 38 | describe "T.filter == List.filter" $ do 39 | prop "T.filter = List.filter" $ \ (Fun _ y) x -> 40 | (T.filter y . T.pack $ x) === (T.pack $ List.filter y $ x) 41 | 42 | describe "T.partition == List.partition" $ do 43 | prop "T.partition = List.partition" $ \ (Fun _ y) x -> 44 | (T.partition y . T.pack $ x) === 45 | (let (a,b) = List.partition y $ x in (T.pack a, T.pack b)) 46 | 47 | -------------------------------------------------------------------------------- /bench/tcp/MIO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Main where 5 | 6 | import Network.Socket hiding (send, recv) 7 | import Network.Socket.ByteString 8 | import GHC.ForeignPtr 9 | import Foreign.ForeignPtr 10 | import Control.Concurrent 11 | import Control.Monad 12 | import qualified Data.ByteString as B 13 | import Control.Concurrent.MVar 14 | import Control.Exception 15 | import Data.IORef.Unboxed 16 | import System.Environment 17 | import Text.Read (readMaybe) 18 | 19 | main :: IO () 20 | main = do 21 | portStr <- lookupEnv "PORT" 22 | let port = maybe 8888 id (readMaybe =<< portStr) 23 | sock <- socket AF_INET Stream defaultProtocol 24 | bind sock $ SockAddrInet port iNADDR_ANY 25 | listen sock 128 26 | cap <- getNumCapabilities 27 | capCounter <- newCounter 0 28 | onException (forever $ do 29 | (sock' , addr) <- accept sock 30 | c <- atomicAddCounter_ capCounter 1 31 | forkOn c $ do 32 | setSocketOption sock' NoDelay 1 33 | recvbuf <- mallocPlainForeignPtrBytes 2048 -- we reuse buffer as golang does, 34 | -- since node use slab, which is in fact a memory pool 35 | -- do not print ECONNRESET for fairness 36 | catch (echo sock' recvbuf) (\ (e::SomeException) -> return ())) 37 | (close sock) 38 | 39 | where 40 | echo sock recvbuf = loop >> close sock 41 | where 42 | loop = do 43 | r <- withForeignPtr recvbuf $ \ p -> do 44 | recvBuf sock p 2048 45 | 46 | when (r /= 0) $ do 47 | sendAll sock sendbuf 48 | loop 49 | 50 | sendbuf = 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\ 55 | \\r\n" `B.append` (B.replicate 500 48) 56 | 57 | -------------------------------------------------------------------------------- /std-io/test/Std/IO/LowResTimerSpec.hs: -------------------------------------------------------------------------------- 1 | module Std.IO.LowResTimerSpec where 2 | 3 | import Control.Concurrent 4 | import Control.Monad 5 | import Control.Monad.IO.Class 6 | import Std.Data.PrimIORef 7 | import Std.IO.LowResTimer 8 | import Test.Hspec 9 | import Test.HUnit 10 | 11 | spec :: Spec 12 | spec = describe "low resolution timers" $ do 13 | it "timers registration should not be missed" $ do 14 | c <- newCounter 0 15 | replicateM_ 10000 $ do 16 | forM_ [1..10] $ \ i -> do 17 | registerLowResTimer i (atomicAddCounter_ c 1) 18 | 19 | threadDelay 1000 20 | lrtm <- getLowResTimerManager 21 | running <- isLowResTimerManagerRunning lrtm 22 | assertEqual "timer manager should start" True running 23 | 24 | threadDelay 1200000 -- make sure all timers are fired 25 | c' <- readPrimIORef c 26 | assertEqual "timers registration counter" 100000 c' 27 | 28 | threadDelay 100000 -- another 0.1s 29 | 30 | lrtm <- getLowResTimerManager 31 | running <- isLowResTimerManagerRunning lrtm 32 | assertEqual "timer manager should stopped" False running 33 | 34 | it "throttle" $ do 35 | c <- newCounter 0 36 | throttledAdd <- throttle 10 (atomicAddCounter_ c 1) 37 | forkIO . replicateM_ 100 $ do 38 | throttledAdd 39 | threadDelay 50000 40 | threadDelay 10000000 -- wait 10s here 41 | c' <- readPrimIORef c 42 | assertBool "throttled add" (6 <= c' && c' <= 7) 43 | 44 | it "throttleTrailing" $ do 45 | c <- newCounter 0 46 | throttledAdd <- throttleTrailing_ 10 (atomicAddCounter_ c 1) 47 | forkIO . replicateM_ 100 $ do 48 | throttledAdd 49 | threadDelay 50000 50 | threadDelay 10000000 -- wait 10s here 51 | c' <- readPrimIORef c 52 | assertBool "throttled add" (5 <= c' && c' <= 6) 53 | -------------------------------------------------------------------------------- /bench/json/bench-aeson.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | 3 | import os, re, subprocess, sys 4 | 5 | result_re = re.compile(r'^\s*(\d+) good, (\d+\.\d+)s$', re.M) 6 | 7 | if len(sys.argv) > 1: 8 | parser_exe = sys.argv[1] 9 | else: 10 | parser_exe = ('dist/build/json-bench-aeson/' + 11 | 'json-bench-aeson') 12 | 13 | def run(count, filename): 14 | print ' %s :: %s times' % (filename, count) 15 | p = subprocess.Popen([parser_exe, '65536', str(count), filename], 16 | stdout=subprocess.PIPE) 17 | output = p.stdout.read() 18 | p.wait() 19 | m = result_re.search(output) 20 | if not m: 21 | print >> sys.stderr, 'run gave confusing output!?' 22 | sys.stderr.write(output) 23 | return 24 | else: 25 | #sys.stdout.write(output) 26 | pass 27 | good, elapsed = m.groups() 28 | good, elapsed = int(good), float(elapsed) 29 | st = os.stat(filename) 30 | parses_per_second = good / elapsed 31 | mb_per_second = st.st_size * parses_per_second / 1048576 32 | print (' %.3f seconds, %d parses/sec, %.3f MB/sec' % 33 | (elapsed, parses_per_second, mb_per_second)) 34 | return parses_per_second, mb_per_second, st.st_size, elapsed 35 | 36 | def runtimes(count, filename, times=1): 37 | for i in xrange(times): 38 | yield run(count, filename) 39 | 40 | info = ''' 41 | json-data/twitter1.json 60000 42 | json-data/twitter10.json 13000 43 | json-data/twitter20.json 7500 44 | json-data/twitter50.json 2500 45 | json-data/twitter100.json 1000 46 | json-data/jp10.json 4000 47 | json-data/jp50.json 1200 48 | json-data/jp100.json 700 49 | ''' 50 | 51 | for i in info.strip().splitlines(): 52 | name, count = i.split() 53 | best = sorted(runtimes(int(count), name, times=3), reverse=True)[0] 54 | parses_per_second, mb_per_second, size, elapsed = best 55 | print ('%.1f KB: %d msg\\/sec (%.1f MB\\/sec)' % 56 | (size / 1024.0, int(round(parses_per_second)), mb_per_second)) 57 | -------------------------------------------------------------------------------- /bench/json/bench-stdio.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | 3 | import os, re, subprocess, sys 4 | 5 | result_re = re.compile(r'^\s*(\d+) good, (\d+\.\d+)s$', re.M) 6 | 7 | if len(sys.argv) > 1: 8 | parser_exe = sys.argv[1] 9 | else: 10 | parser_exe = ('dist/build/json-bench-stdio/' + 11 | 'json-bench-stdio') 12 | 13 | def run(count, filename): 14 | print ' %s :: %s times' % (filename, count) 15 | p = subprocess.Popen([parser_exe, '65536', str(count), filename], 16 | stdout=subprocess.PIPE) 17 | output = p.stdout.read() 18 | p.wait() 19 | m = result_re.search(output) 20 | if not m: 21 | print >> sys.stderr, 'run gave confusing output!?' 22 | sys.stderr.write(output) 23 | return 24 | else: 25 | #sys.stdout.write(output) 26 | pass 27 | good, elapsed = m.groups() 28 | good, elapsed = int(good), float(elapsed) 29 | st = os.stat(filename) 30 | parses_per_second = good / elapsed 31 | mb_per_second = st.st_size * parses_per_second / 1048576 32 | print (' %.3f seconds, %d parses/sec, %.3f MB/sec' % 33 | (elapsed, parses_per_second, mb_per_second)) 34 | return parses_per_second, mb_per_second, st.st_size, elapsed 35 | 36 | def runtimes(count, filename, times=1): 37 | for i in xrange(times): 38 | yield run(count, filename) 39 | 40 | info = ''' 41 | json-data/twitter1.json 60000 42 | json-data/twitter10.json 13000 43 | json-data/twitter20.json 7500 44 | json-data/twitter50.json 2500 45 | json-data/twitter100.json 1000 46 | json-data/jp10.json 4000 47 | json-data/jp50.json 1200 48 | json-data/jp100.json 700 49 | ''' 50 | 51 | for i in info.strip().splitlines(): 52 | name, count = i.split() 53 | best = sorted(runtimes(int(count), name, times=3), reverse=True)[0] 54 | parses_per_second, mb_per_second, size, elapsed = best 55 | print ('%.1f KB: %d msg\\/sec (%.1f MB\\/sec)' % 56 | (size / 1024.0, int(round(parses_per_second)), mb_per_second)) 57 | -------------------------------------------------------------------------------- /std-data/include/bytes.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2017-2018 Dong Han 3 | * 4 | * All rights reserved. 5 | * 6 | * Redistribution and use in source and binary forms, with or without 7 | * modification, are permitted provided that the following conditions 8 | * are met: 9 | * 1. Redistributions of source code must retain the above copyright 10 | * notice, this list of conditions and the following disclaimer. 11 | * 2. Redistributions in binary form must reproduce the above copyright 12 | * notice, this list of conditions and the following disclaimer in the 13 | * documentation and/or other materials provided with the distribution. 14 | * 3. Neither the names of the authors or the names of any contributors 15 | * may be used to endorse or promote products derived from this software 16 | * without specific prior written permission. 17 | * 18 | * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 19 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 22 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 24 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 25 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 26 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 27 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 28 | * SUCH DAMAGE. 29 | */ 30 | 31 | #include 32 | #include 33 | #include 34 | 35 | HsInt hs_memchr(uint8_t *a, HsInt aoff, uint8_t b, HsInt n); 36 | HsInt hs_memrchr(uint8_t *a, HsInt aoff, uint8_t c, HsInt n); 37 | HsInt hs_fnv_hash_addr(const unsigned char* str, HsInt len, HsInt salt); 38 | HsInt hs_fnv_hash(const unsigned char* str, HsInt offset, HsInt len, HsInt salt); 39 | -------------------------------------------------------------------------------- /bench/json/bench-aeson-lazy.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | 3 | import os, re, subprocess, sys 4 | 5 | result_re = re.compile(r'^\s*(\d+) good, (\d+\.\d+)s$', re.M) 6 | 7 | if len(sys.argv) > 1: 8 | parser_exe = sys.argv[1] 9 | else: 10 | parser_exe = ('dist/build/json-bench-aeson-lazy/' + 11 | 'json-bench-aeson-lazy') 12 | 13 | def run(count, filename): 14 | print ' %s :: %s times' % (filename, count) 15 | p = subprocess.Popen([parser_exe, '65536', str(count), filename], 16 | stdout=subprocess.PIPE) 17 | output = p.stdout.read() 18 | p.wait() 19 | m = result_re.search(output) 20 | if not m: 21 | print >> sys.stderr, 'run gave confusing output!?' 22 | sys.stderr.write(output) 23 | return 24 | else: 25 | #sys.stdout.write(output) 26 | pass 27 | good, elapsed = m.groups() 28 | good, elapsed = int(good), float(elapsed) 29 | st = os.stat(filename) 30 | parses_per_second = good / elapsed 31 | mb_per_second = st.st_size * parses_per_second / 1048576 32 | print (' %.3f seconds, %d parses/sec, %.3f MB/sec' % 33 | (elapsed, parses_per_second, mb_per_second)) 34 | return parses_per_second, mb_per_second, st.st_size, elapsed 35 | 36 | def runtimes(count, filename, times=1): 37 | for i in xrange(times): 38 | yield run(count, filename) 39 | 40 | info = ''' 41 | json-data/twitter1.json 60000 42 | json-data/twitter10.json 13000 43 | json-data/twitter20.json 7500 44 | json-data/twitter50.json 2500 45 | json-data/twitter100.json 1000 46 | json-data/jp10.json 4000 47 | json-data/jp50.json 1200 48 | json-data/jp100.json 700 49 | ''' 50 | 51 | for i in info.strip().splitlines(): 52 | name, count = i.split() 53 | best = sorted(runtimes(int(count), name, times=3), reverse=True)[0] 54 | parses_per_second, mb_per_second, size, elapsed = best 55 | print ('%.1f KB: %d msg\\/sec (%.1f MB\\/sec)' % 56 | (size / 1024.0, int(round(parses_per_second)), mb_per_second)) 57 | -------------------------------------------------------------------------------- /bench/tcp/golang/main.go: -------------------------------------------------------------------------------- 1 | package main 2 | 3 | import ( 4 | "fmt" 5 | "net" 6 | "os" 7 | ) 8 | 9 | const ( 10 | CONN_HOST = "0.0.0.0" 11 | CONN_TYPE = "tcp" 12 | ) 13 | 14 | var response []byte = []byte("HTTP/1.1 200 OK\r\n" + 15 | "Content-Type: text/html; charset=UTF-8\r\n" + 16 | "Content-Length: 500\r\n" + 17 | "Connection: Keep-Alive\r\n\r\n" + "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000") 18 | 19 | func main() { 20 | // Listen for incoming connections. 21 | port := "8888" 22 | if os.Getenv("PORT") != "" { 23 | port = os.Getenv("PORT") 24 | } 25 | l, err := net.Listen(CONN_TYPE, CONN_HOST+":"+port) 26 | if err != nil { 27 | fmt.Println("Error listening:", err.Error()) 28 | os.Exit(1) 29 | } 30 | // Close the listener when the application closes. 31 | defer l.Close() 32 | fmt.Println("Listening on " + CONN_HOST + ":" + port) 33 | for { 34 | // Listen for an incoming connection. 35 | conn, err := l.Accept() 36 | if err != nil { 37 | fmt.Println("Error accepting: ", err.Error()) 38 | os.Exit(1) 39 | } 40 | // Handle connections in a new goroutine. 41 | go handleRequest(conn) 42 | } 43 | } 44 | 45 | // Handles incoming requests. 46 | func handleRequest(conn net.Conn) { 47 | // Make a buffer to hold incoming data. 48 | buf := make([]byte, 2048) 49 | 50 | for { 51 | // Read the incoming connection into the buffer. 52 | _, err := conn.Read(buf) 53 | if err == nil { 54 | // Send a response back to person contacting us. 55 | conn.Write(response) 56 | } else { 57 | // Close the connection when you're done with it. 58 | conn.Close() 59 | break 60 | } 61 | } 62 | } 63 | -------------------------------------------------------------------------------- /std-data/Std/Data/Builder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MagicHash #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE UnboxedTuples #-} 9 | 10 | {-| 11 | Module : Std.Data.Builder 12 | Description : Efficient serialization/format. 13 | Copyright : (c) Dong Han, 2017-2018 14 | License : BSD 15 | Maintainer : winterland1989@gmail.com 16 | Stability : experimental 17 | Portability : non-portable 18 | 19 | A 'Builder' records a buffer writing function, which can be 'mappend' in O(1) via composition. This module provides many functions to turn basic data types into 'Builder's, which can used to build strict 'Bytes' or list of 'Bytes' chunks. 20 | 21 | -} 22 | 23 | module Std.Data.Builder 24 | ( -- * Builder type 25 | Builder 26 | , append 27 | -- * Running builders 28 | , buildBytes 29 | , buildBytesWith 30 | , buildBytesList 31 | , buildBytesListWith 32 | , buildAndRun 33 | , buildAndRunWith 34 | -- * Basic buiders 35 | , bytes 36 | , ensureN 37 | , atMost 38 | , writeN 39 | -- * Pritimive builders 40 | , encodePrim 41 | , encodePrimLE 42 | , encodePrimBE 43 | -- * More builders 44 | , stringModifiedUTF8, charModifiedUTF8, stringUTF8, charUTF8, string7, char7, string8, char8, text 45 | -- * Numeric builders 46 | -- ** Integral type formatting 47 | , IFormat(..) 48 | , defaultIFormat 49 | , Padding(..) 50 | , int 51 | , intWith 52 | , integer 53 | -- ** Fixded size hexidecimal formatting 54 | , hex, heX 55 | -- ** IEEE float formating 56 | , FFormat(..) 57 | , double 58 | , doubleWith 59 | , float 60 | , floatWith 61 | , scientific 62 | , scientificWith 63 | -- * Builder helpers 64 | , paren, curly, square, angle, quotes, squotes, colon, comma, intercalateVec, intercalateList 65 | ) where 66 | 67 | import Std.Data.Builder.Base 68 | import Std.Data.Builder.Numeric 69 | -------------------------------------------------------------------------------- /std-data/Std/Data/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE MagicHash #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | 8 | {-| 9 | Module : Std.Data.Parser 10 | Description : Efficient deserialization/parse. 11 | Copyright : (c) Dong Han, 2017-2018 12 | License : BSD 13 | Maintainer : winterland1989@gmail.com 14 | Stability : experimental 15 | Portability : non-portable 16 | 17 | This module provide a simple resumable 'Parser', which is suitable for binary protocol and simple textual protocol parsing. 18 | 19 | You can use 'Alternative' instance to do backtracking, each branch will either succeed and may consume some input, or fail without consume anything. It's recommend to use 'peek' to avoid backtracking if possible to get high performance. 20 | 21 | -} 22 | module Std.Data.Parser 23 | ( -- * Parser types 24 | Result(..) 25 | , ParseError 26 | , Parser 27 | , () 28 | -- * Running a parser 29 | , parse, parse_, parseChunk, parseChunks, finishParsing 30 | , runAndKeepTrack, match 31 | -- * Basic parsers 32 | , ensureN, endOfInput, atEnd 33 | -- * Primitive decoders 34 | , decodePrim, decodePrimLE, decodePrimBE 35 | -- * More parsers 36 | , scan, scanChunks, peekMaybe, peek, satisfy, satisfyWith 37 | , word8, char8, skipWord8, endOfLine, skip, skipWhile, skipSpaces 38 | , take, takeTill, takeWhile, takeWhile1, bytes, bytesCI 39 | , text 40 | -- * Numeric parsers 41 | -- ** Decimal 42 | , uint, int 43 | -- ** Hex 44 | , hex 45 | -- ** Fractional 46 | , rational 47 | , float, double 48 | , scientific 49 | , scientifically 50 | -- * Stricter fractional(rfc8259) 51 | , rational' 52 | , float', double' 53 | , scientific' 54 | , scientifically' 55 | -- * Misc 56 | , isSpace, isHexDigit, isDigit 57 | ) where 58 | 59 | import Std.Data.Parser.Base 60 | import Std.Data.Parser.Numeric 61 | import Prelude hiding (take, takeWhile) 62 | -------------------------------------------------------------------------------- /bench/json/json-bench.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | -- Initial package description 'json-bench.cabal' generated by 'cabal 3 | -- init'. For further documentation, see 4 | -- http://haskell.org/cabal/users-guide/ 5 | 6 | name: json-bench 7 | version: 0.1.0.0 8 | -- synopsis: 9 | -- description: 10 | -- bug-reports: 11 | license: BSD3 12 | license-file: LICENSE 13 | author: winterland1989 14 | maintainer: winterland1989@gmail.com 15 | -- copyright: 16 | -- category: 17 | build-type: Simple 18 | extra-source-files: CHANGELOG.md 19 | 20 | executable json-bench-aeson 21 | main-is: Aeson.hs 22 | -- other-modules: 23 | -- other-extensions: 24 | build-depends: base >=4.12 && <4.13 25 | , aeson 26 | , time 27 | , attoparsec 28 | , bytestring 29 | -- hs-source-dirs: 30 | default-language: Haskell2010 31 | ghc-options: -O 32 | 33 | executable json-bench-aeson-lazy 34 | main-is: AesonLazy.hs 35 | -- other-modules: 36 | -- other-extensions: 37 | build-depends: base >=4.12 && <4.13 38 | , aeson 39 | , time 40 | , attoparsec 41 | , bytestring 42 | -- hs-source-dirs: 43 | default-language: Haskell2010 44 | ghc-options: -O 45 | 46 | executable json-bench-stdio 47 | main-is: Stdio.hs 48 | -- other-modules: 49 | -- other-extensions: 50 | build-depends: base >=4.12 && <4.13 51 | , std-data 52 | , time 53 | -- hs-source-dirs: 54 | default-language: Haskell2010 55 | ghc-options: -O 56 | 57 | executable aeson-benchmark-auto-compare 58 | default-language: Haskell2010 59 | main-is: AutoCompare.hs 60 | hs-source-dirs: . 61 | ghc-options: -Wall -O2 -rtsopts 62 | other-modules: 63 | Auto.T.D 64 | Auto.T.BigRecord 65 | Auto.T.BigProduct 66 | Auto.T.BigSum 67 | Auto.G.D 68 | Auto.G.BigRecord 69 | Auto.G.BigProduct 70 | Auto.G.BigSum 71 | Options 72 | build-depends: 73 | aeson, 74 | std-data, 75 | base, 76 | criterion, 77 | deepseq, 78 | template-haskell 79 | -------------------------------------------------------------------------------- /std-data/test/Std/Data/CBytesSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Std.Data.CBytesSpec where 6 | 7 | import qualified Data.List as List 8 | import Data.Word 9 | import Data.Hashable (hashWithSalt, hash) 10 | import qualified Std.Data.CBytes as CB 11 | import qualified Std.Data.Vector.Base as V 12 | import Test.QuickCheck 13 | import Test.QuickCheck.Function 14 | import Test.QuickCheck.Property 15 | import Test.Hspec 16 | import Test.Hspec.QuickCheck 17 | 18 | spec :: Spec 19 | spec = describe "CBytes-base" $ do 20 | describe "CBytes Eq Ord property" . modifyMaxSuccess (*10) . modifyMaxSize (*10) $ do 21 | prop "CBytes eq === List.eq" $ \ xs ys -> 22 | (CB.pack xs == CB.pack ys) === (xs == ys) 23 | 24 | prop "CBytes compare === List.compare" $ \ xs ys -> 25 | let xs' = List.filter (/= '\NUL') xs 26 | ys' = List.filter (/= '\NUL') ys 27 | in (CB.pack xs' `compare` CB.pack ys') === (xs' `compare` ys') 28 | 29 | describe "CBytes Hashable instance property" . modifyMaxSuccess (*10) . modifyMaxSize (*10) $ do 30 | prop "CBytes a's hash should be equal to Bytes's hash" $ \ (ASCIIString xs) -> 31 | let ys = List.filter (/= '\NUL') xs 32 | in hash (CB.pack ys) === hash (V.packASCII ys) 33 | prop "CBytes a's hash should be equal to literal's hash" $ 34 | hash ("hello world!" :: CB.CBytes) === hash (CB.fromBytes "hello world!") 35 | 36 | describe "CBytes IsString instance property" $ do 37 | prop "ASCII string" $ 38 | "hello world" === CB.fromText "hello world" 39 | prop "UTF8 string" $ 40 | "你好世界" === CB.fromText "你好世界" 41 | 42 | describe "CBytes length == List.length" $ do 43 | prop "CBytes length === List.length" $ \ (ASCIIString xs) -> 44 | let ys = List.filter (/= '\NUL') xs 45 | in (CB.length $ CB.pack ys) === List.length ys 46 | 47 | describe "CBytes append == List.(++)" $ do 48 | prop "CBytes eq === List.eq" $ \ xs ys -> 49 | (CB.pack xs `CB.append` CB.pack ys) === CB.pack (xs ++ ys) 50 | -------------------------------------------------------------------------------- /.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=2.4 GHCVER=8.6.2 9 | - CABALVER=head GHCVER=head # see section about GHC HEAD snapshots 10 | 11 | matrix: 12 | allow_failures: 13 | - env: CABALVER=head GHCVER=head 14 | 15 | 16 | # Note: the distinction between `before_install` and `install` is not important. 17 | before_install: 18 | - travis_retry sudo add-apt-repository -y ppa:hvr/ghc 19 | - travis_retry sudo apt-get update 20 | - travis_retry sudo apt-get install --allow-unauthenticated cabal-install-$CABALVER ghc-$GHCVER 21 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 22 | - git clone https://github.com/libuv/libuv.git && cd libuv && git checkout tags/v1.24.0 && sh autogen.sh && ./configure && make && sudo make install && cd .. 23 | - export PATH="$HOME/.cabal/bin:/usr/local/lib:$PATH" # for build-tools 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 | 27 | install: 28 | - git submodule update --init 29 | - cabal --version 30 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 31 | - travis_retry cabal update 32 | - cabal install hspec-discover 33 | 34 | # 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. 35 | script: 36 | - if [ -f configure.ac ]; then autoreconf -i; fi 37 | - cabal new-build 38 | - cabal new-run test 39 | - cabal check 40 | - cabal sdist # tests that a source-distribution can be generated 41 | 42 | # Check that the resulting source distribution can be built & installed. 43 | # If there are no other `.tar.gz` files in `dist`, this can be even simpler: 44 | # `cabal install --force-reinstalls dist/*-*.tar.gz` 45 | - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && 46 | (cd dist && cabal install --force-reinstalls $EXTRA_OPT "$SRC_TGZ") 47 | -------------------------------------------------------------------------------- /std-data/Std/Data/Builder/Numeric/DigitTable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE NoCPP #-} 3 | 4 | {-| 5 | Module : Std.Data.Builder.Numeric.DigitTable 6 | Description : Numeric to ASCII digits table. 7 | Copyright : (c) Dong Han, 2017-2019 8 | License : BSD 9 | Maintainer : winterland1989@gmail.com 10 | Stability : experimental 11 | Portability : non-portable 12 | 13 | -} 14 | module Std.Data.Builder.Numeric.DigitTable where 15 | 16 | import Data.Primitive.Addr 17 | 18 | decDigitTable :: Addr 19 | decDigitTable = Addr "0001020304050607080910111213141516171819\ 20 | \2021222324252627282930313233343536373839\ 21 | \4041424344454647484950515253545556575859\ 22 | \6061626364656667686970717273747576777879\ 23 | \8081828384858687888990919293949596979899"# 24 | 25 | hexDigitTable :: Addr 26 | hexDigitTable = Addr "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f\ 27 | \202122232425262728292a2b2c2d2e2f303132333435363738393a3b3c3d3e3f\ 28 | \404142434445464748494a4b4c4d4e4f505152535455565758595a5b5c5d5e5f\ 29 | \606162636465666768696a6b6c6d6e6f707172737475767778797a7b7c7d7e7f\ 30 | \808182838485868788898a8b8c8d8e8f909192939495969798999a9b9c9d9e9f\ 31 | \a0a1a2a3a4a5a6a7a8a9aaabacadaeafb0b1b2b3b4b5b6b7b8b9babbbcbdbebf\ 32 | \c0c1c2c3c4c5c6c7c8c9cacbcccdcecfd0d1d2d3d4d5d6d7d8d9dadbdcdddedf\ 33 | \e0e1e2e3e4e5e6e7e8e9eaebecedeeeff0f1f2f3f4f5f6f7f8f9fafbfcfdfeff"# 34 | 35 | hexDigitTableUpper :: Addr 36 | hexDigitTableUpper = Addr "000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F\ 37 | \202122232425262728292A2B2C2D2E2F303132333435363738393A3B3C3D3E3F\ 38 | \404142434445464748494A4B4C4D4E4F505152535455565758595A5B5C5D5E5F\ 39 | \606162636465666768696A6B6C6D6E6F707172737475767778797A7B7C7D7E7F\ 40 | \808182838485868788898A8B8C8D8E8F909192939495969798999A9B9C9D9E9F\ 41 | \A0A1A2A3A4A5A6A7A8A9AAABACADAEAFB0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF\ 42 | \C0C1C2C3C4C5C6C7C8C9CACBCCCDCECFD0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF\ 43 | \E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEFF0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF"# 44 | -------------------------------------------------------------------------------- /bench/data/Text.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module Text (text) where 7 | 8 | import Criterion.Main 9 | import qualified Data.ByteString as BS 10 | import qualified Data.Text as T 11 | import qualified Std.Data.Text as S 12 | import qualified Std.Data.Vector as V 13 | import Control.DeepSeq 14 | import Control.Monad 15 | import Control.Exception (evaluate) 16 | import Data.Monoid ((<>)) 17 | import Data.Word 18 | import qualified Data.List as List 19 | 20 | import Prelude hiding (reverse,head,tail,last,init,null 21 | ,length,map,lines,foldl,foldr,unlines 22 | ,concat,any,take,drop,splitAt,takeWhile 23 | ,dropWhile,span,break,elem,filter,maximum 24 | ,minimum,all,concatMap,foldl1,foldr1 25 | ,scanl,scanl1,scanr,scanr1 26 | ,readFile,writeFile,appendFile,replicate 27 | ,getContents,getLine,putStr,putStrLn,interact 28 | ,zip,zipWith,unzip,notElem 29 | ) 30 | 31 | text :: T.Text -> S.Text -> [Benchmark] 32 | text t st = List.reverse 33 | [ bgroup "pack" (pack1000 t st) 34 | , bgroup "unpack" (unpack1000 t st) 35 | , bgroup "last" (last t st) 36 | , bgroup "length" (length t st) 37 | , bgroup "map" (map t st) 38 | , bgroup "reverse" (reverse t st) 39 | ] 40 | 41 | unpack1000 :: T.Text -> S.Text -> [Benchmark] 42 | unpack1000 t st = 43 | [ bench "text/unpack" $ nf T.unpack t 44 | , bench "stdio text/unpack" $ nf S.unpack st 45 | ] 46 | 47 | pack1000 :: T.Text -> S.Text -> [Benchmark] 48 | pack1000 t st = 49 | [ bench "text/pack" $ nf T.pack (List.replicate 1000 '0') 50 | , bench "stdio text/pack" $ nf S.pack (List.replicate 1000 '0') 51 | ] 52 | 53 | last :: T.Text -> S.Text -> [Benchmark] 54 | last t st = 55 | [ bench "text/last" $ nf T.last t 56 | , bench "stdio text/last" $ nf S.lastMaybe st 57 | ] 58 | 59 | length :: T.Text -> S.Text -> [Benchmark] 60 | length t st = 61 | [ bench "text/length" $ nf T.length t 62 | , bench "stdio text/length" $ nf S.length st 63 | ] 64 | 65 | map :: T.Text -> S.Text -> [Benchmark] 66 | map t st = 67 | [ bench "text/map" $ nf (T.map id) t 68 | , bench "stdio text/map" $ nf (S.map' id) st 69 | ] 70 | 71 | reverse :: T.Text -> S.Text -> [Benchmark] 72 | reverse t st = 73 | [ bench "text/reverse" $ nf T.reverse t 74 | , bench "stdio text/reverse" $ nf S.reverse st 75 | ] 76 | -------------------------------------------------------------------------------- /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 | A result run by me on large core server can be find [here](https://github.com/haskell-stdio/stdio/blob/master/bench/tcp/result.md), with [summary here](https://github.com/haskell-stdio/stdio/blob/master/bench/tcp/result-summary.pdf). 23 | 24 | Run test 25 | -------- 26 | 27 | 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), then 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. 28 | 29 | You should adjust your system's fd limit before running benchmark in case of running out of fd. 30 | 31 | ``` 32 | # You should install stdio first, either into global or into tcp's sandbox 33 | cabal build 34 | 35 | # Adding a proper heap size hint is important for haskell programs because 36 | # the way GHC's GC works. 37 | # You should use a -Hx parammeter if the concurrent level go beyong ~1k. 38 | # Quick formula: concurrent level(in K) * 128M, for example use -H128M for C1K. 39 | 40 | # mio, if you know your CPU's core number x, append a -Nx 41 | ./dist/build/mio/mio +RTS -s 42 | 43 | # stdio, if you know your CPU's core number x, append a -Nx 44 | ./dist/build/libuv/libuv +RTS -s 45 | 46 | # golang 47 | go run golang/main.go 48 | 49 | # nodejs, if you know your CPU's core number x, set it with env CPU_NUM=x 50 | node nodejs/main.js 51 | 52 | # wrk 53 | wrk -c1000 -d10s http://127.0.0.1:8888 54 | 55 | # siege 56 | siege -c 1000 -r 10 http://127.0.0.1:8888 57 | 58 | # ab 59 | ab -r -k -c 100 -n 30000 http://127.0.0.1:8888/ 60 | ... 61 | ``` 62 | -------------------------------------------------------------------------------- /std-data/test/Std/Data/TextBuilderSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | 7 | module Std.Data.TextBuilderSpec where 8 | 9 | import qualified Data.List as L 10 | import Data.Word 11 | import Data.Int 12 | import GHC.Generics 13 | import qualified Std.Data.Text as T 14 | import Std.Data.TextBuilder 15 | import Std.Data.JSON (Value) 16 | import Test.QuickCheck 17 | import Test.QuickCheck.Function 18 | import Test.QuickCheck.Property 19 | import Test.Hspec 20 | import Test.Hspec.QuickCheck 21 | 22 | 23 | data T a 24 | = Nullary 25 | | Unary Int 26 | | Product T.Text (Maybe Char) a 27 | | Record { testOne :: Double 28 | , testTwo :: Maybe Bool 29 | , testThree :: Maybe a 30 | } 31 | | List [a] 32 | deriving (Show, Eq, ToText, Generic) 33 | 34 | data I a = I a :+ I a | I a :- I a | J a deriving (Show, Generic, ToText) 35 | infixr 5 :+ 36 | infixl 6 :- 37 | 38 | spec :: Spec 39 | spec = describe "JSON Base instances" $ do 40 | 41 | it "Nullary constructor are encoded as text" $ 42 | toText (Nullary :: T Integer) === "Nullary" 43 | 44 | it "Unary constructor are encoded as single field" $ 45 | toText (Unary 123456 :: T Integer) === "Unary 123456" 46 | 47 | it "Product are encoded as multiple field" $ 48 | toText (Product "ABC" (Just 'x') (123456::Integer)) === 49 | "Product \"ABC\" (Just 'x') 123456" 50 | 51 | it "Record are encoded as key values" $ 52 | toText (Record 0.123456 Nothing (Just (123456::Integer))) === 53 | "Record {testOne = 0.123456, testTwo = Nothing, testThree = Just 123456}" 54 | 55 | it "List are encode as array" $ 56 | toText (List [Nullary 57 | , Unary 123456 58 | , (Product "ABC" (Just 'x') (123456::Integer)) 59 | , (Record 0.123456 Nothing (Just (123456::Integer)))]) === 60 | "List [Nullary,Unary 123456,Product \"ABC\" (Just 'x') 123456,\ 61 | \Record {testOne = 0.123456, testTwo = Nothing, testThree = Just 123456}]" 62 | 63 | it "infix constructor should respect piority" $ 64 | toString (J 1 :- J 2 :+ J 3 :- J 4 :- J 5 :+ J 6 :+ J 7 :+ J 8 :- J 9 :- J 10 :- J 11 :: I Int) 65 | === show (J 1 :- J 2 :+ J 3 :- J 4 :- J 5 :+ J 6 :+ J 7 :+ J 8 :- J 9 :- J 10 :- J 11) 66 | 67 | prop "Value Show instance === ToText instances" $ \ (v :: Value) -> 68 | toString v === show v 69 | -------------------------------------------------------------------------------- /std-data/test/Std/Data/LEONSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DeriveAnyClass #-} 5 | 6 | module Std.Data.LEONSpec where 7 | 8 | import qualified Data.List as List 9 | import Data.Word 10 | import Data.Int 11 | import GHC.Natural 12 | import qualified Std.Data.Builder as B 13 | import qualified Std.Data.Parser as P 14 | import qualified Std.Data.CBytes as CB 15 | import qualified Std.Data.Text as T 16 | import qualified Std.Data.Vector.Base as V 17 | import qualified Std.Data.LEON as LEON 18 | import GHC.Generics 19 | import Test.QuickCheck 20 | import Test.QuickCheck.Function 21 | import Test.QuickCheck.Property 22 | import Test.Hspec 23 | import Test.Hspec.QuickCheck 24 | 25 | data Test1 = Test1 Int8 Int16 Int32 Int64 Int Word8 Word16 Word32 Word64 Word 26 | deriving (Generic, LEON.LEON, Eq, Show) 27 | 28 | data Test2 = Test2 (LEON.BE Int16) (LEON.BE Word32) (LEON.BE Int64) (LEON.BE Word) 29 | deriving (Generic, LEON.LEON, Eq, Show) 30 | 31 | data Test3 = Test3Integer Integer | Test3Natural Natural 32 | deriving (Generic, LEON.LEON, Eq, Show) 33 | 34 | data Test4 = Test4 [Integer] 35 | deriving (Generic, LEON.LEON, Eq, Show) 36 | 37 | data Test5 = Test5 Ordering Bool 38 | deriving (Generic, LEON.LEON, Eq, Show) 39 | 40 | data Test6 = Test6 (V.Vector Integer) V.Bytes (V.PrimVector Int) T.Text CB.CBytes 41 | deriving (Generic, LEON.LEON, Eq, Show) 42 | 43 | spec :: Spec 44 | spec = describe "LEON instance roundtrip" . modifyMaxSuccess (*10) . modifyMaxSize (*10) $ do 45 | prop "Test1 roundtrip" $ \ a b c d e f g h i j -> 46 | let t = Test1 a b c d e f g h i j 47 | in P.parse_ LEON.decode (B.buildBytes $ LEON.encode t) === Right t 48 | 49 | prop "Test2 roundtrip" $ \ a b c d -> 50 | let t = Test2 (LEON.BE a) (LEON.BE b) (LEON.BE c) (LEON.BE d) 51 | in P.parse_ LEON.decode (B.buildBytes $ LEON.encode t) === Right t 52 | 53 | prop "Test3 roundtrip" $ \ a b (Positive c) -> 54 | let t = if a then Test3Integer b else Test3Natural (fromIntegral (c :: Integer)) 55 | in P.parse_ LEON.decode (B.buildBytes $ LEON.encode t) === Right t 56 | 57 | prop "Test4 roundtrip" $ \ xs -> 58 | let t = Test4 xs 59 | in P.parse_ LEON.decode (B.buildBytes $ LEON.encode t) === Right t 60 | 61 | prop "Test5 roundtrip" $ \ a b -> 62 | let t = Test5 a b 63 | in P.parse_ LEON.decode (B.buildBytes $ LEON.encode t) === Right t 64 | 65 | prop "Test6 roundtrip" $ \ xs ys zs ts bs -> 66 | let t = Test6 (V.pack xs) (V.pack ys) (V.pack zs) (T.pack ts) (CB.pack bs) 67 | in P.parse_ LEON.decode (B.buildBytes $ LEON.encode t) === Right t 68 | -------------------------------------------------------------------------------- /std-data/test/Std/Data/JSON/BaseSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | 7 | module Std.Data.JSON.BaseSpec where 8 | 9 | import qualified Data.List as L 10 | import Data.Word 11 | import Data.Int 12 | import GHC.Generics 13 | import qualified Std.Data.Text as T 14 | import qualified Std.Data.Builder as B 15 | import Test.QuickCheck 16 | import Test.QuickCheck.Function 17 | import Test.QuickCheck.Property 18 | import Test.Hspec 19 | import Test.Hspec.QuickCheck 20 | import qualified Std.Data.JSON as JSON 21 | import Std.Data.JSON (FromValue, ToValue, EncodeJSON) 22 | 23 | 24 | data T a 25 | = Nullary 26 | | Unary Int 27 | | Product T.Text (Maybe Char) a 28 | | Record { testOne :: Double 29 | , testTwo :: Maybe Bool 30 | , testThree :: Maybe a 31 | } 32 | | List [a] 33 | deriving (Show, Eq, Generic, FromValue, ToValue, EncodeJSON) 34 | 35 | spec :: Spec 36 | spec = describe "JSON Base instances" $ do 37 | 38 | it "Nullary constructor are encoded as text" $ 39 | JSON.encodeText (Nullary :: T Integer) === "\"Nullary\"" 40 | 41 | it "Unary constructor are encoded as single field object" $ 42 | JSON.encodeText (Unary 123456 :: T Integer) === "{\"Unary\":123456}" 43 | 44 | it "Product are encoded as array" $ 45 | JSON.encodeText (Product "ABC" (Just 'x') (123456::Integer)) === 46 | "{\"Product\":[\"ABC\",\"x\",123456]}" 47 | 48 | it "Record are encoded as key values" $ 49 | JSON.encodeText (Record 0.123456 Nothing (Just (123456::Integer))) === 50 | "{\"Record\":{\ 51 | \\"testOne\":0.123456,\ 52 | \\"testTwo\":null,\ 53 | \\"testThree\":123456}}" 54 | 55 | it "List are encode as array" $ 56 | JSON.encodeText (List [Nullary 57 | , Unary 123456 58 | , (Product "ABC" (Just 'x') (123456::Integer)) 59 | , (Record 0.123456 Nothing (Just (123456::Integer)))]) === 60 | "{\"List\":[\"Nullary\",\ 61 | \{\"Unary\":123456},\ 62 | \{\"Product\":[\"ABC\",\"x\",123456]},\ 63 | \{\"Record\":{\ 64 | \\"testOne\":0.123456,\ 65 | \\"testTwo\":null,\ 66 | \\"testThree\":123456}}]}" 67 | 68 | it "control characters are escaped" $ 69 | JSON.encodeText (T.pack $ map toEnum [0..0x1F]) === 70 | "\"\\u0000\\u0001\\u0002\\u0003\\u0004\\u0005\\u0006\\u0007\\b\\t\\n\\u000b\\f\\r\\u000e\\u000f\ 71 | \\\u0010\\u0011\\u0012\\u0013\\u0014\\u0015\\u0016\\u0017\\u0018\\u0019\\u001a\\u001b\\u001c\\u001d\\u001e\\u001f\"" 72 | -------------------------------------------------------------------------------- /std-data/cbits/bytes.c: -------------------------------------------------------------------------------- 1 | /* 2 | Copyright (c) 2017-2019 Dong Han 3 | Copyright Johan Tibell 2011, Dong Han 2019 4 | All rights reserved. 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | * Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | * Redistributions in binary form must reproduce the above 10 | copyright notice, this list of conditions and the following 11 | disclaimer in the documentation and/or other materials provided 12 | with the distribution. 13 | * Neither the name of Johan Tibell nor the names of other 14 | contributors may be used to endorse or promote products derived 15 | from this software without specific prior written permission. 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | */ 28 | 29 | #include 30 | 31 | HsInt hs_memchr(uint8_t *a, HsInt aoff, uint8_t b, HsInt n) { 32 | a += aoff; 33 | uint8_t *p = memchr(a, b, (size_t)n); 34 | if (p == NULL) return -1; 35 | else return (p - a); 36 | } 37 | 38 | HsInt hs_memrchr(uint8_t *a, HsInt aoff, uint8_t c, HsInt n) { 39 | const uint8_t *s = a + aoff; 40 | #ifdef __GLIBC__ 41 | uint8_t *p = memrchr(s, c, (size_t)n); 42 | if (p == NULL) return -1; 43 | else return (p - a); 44 | #else 45 | const uint8_t *cp; 46 | if (n != 0) { 47 | cp = (uint8_t *)s + n; 48 | do { 49 | if (*(--cp) == c) 50 | return (cp-s); 51 | } while (--n != 0); 52 | } 53 | return -1; 54 | #endif 55 | } 56 | 57 | /* FNV-1 hash 58 | * 59 | * The FNV-1 hash description: http://isthe.com/chongo/tech/comp/fnv/ 60 | * The FNV-1 hash is public domain: http://isthe.com/chongo/tech/comp/fnv/#public_domain 61 | * 62 | * The original version from hashable use long type which doesn't match 'Int' in haskell and 63 | * cause problems on window, here we use HsInt. 64 | */ 65 | HsInt hs_fnv_hash_addr(const unsigned char* str, HsInt len, HsInt salt) { 66 | 67 | HsWord hash = salt; 68 | while (len--) { 69 | hash = (hash * 16777619) ^ *str++; 70 | } 71 | 72 | return hash; 73 | } 74 | 75 | HsInt hs_fnv_hash(const unsigned char* str, HsInt offset, HsInt len, HsInt salt) { 76 | return hs_fnv_hash_addr(str + offset, len, salt); 77 | } 78 | -------------------------------------------------------------------------------- /std-io/test/Std/IO/UDPSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Std.IO.UDPSpec where 4 | 5 | import Control.Concurrent 6 | import Control.Monad 7 | import Data.Bits 8 | import Std.Data.Vector as V 9 | import Std.Data.Vector.Base as V 10 | import Data.List as List 11 | import Foreign.Marshal.Array 12 | import Foreign.Ptr 13 | import Std.IO.Exception 14 | import Std.IO.UDP 15 | import Std.IO.Resource 16 | import Std.IO.SockAddr 17 | import Test.Hspec 18 | import Test.HUnit 19 | 20 | spec :: Spec 21 | spec = describe "UDP operations" $ do 22 | it "roundtrip test" $ do 23 | let testMsg = V.replicate 256 48 24 | longMsg = V.replicate 2048 48 25 | addr = SockAddrInet 12345 inetLoopback 26 | withResource (initUDP defaultUDPConfig{sendMsgSize = 2048}) $ \ c -> 27 | withResource (initUDP defaultUDPConfig{localUDPAddr = Just (addr,UV_UDP_DEFAULT)}) $ \ s -> do 28 | forkIO $ sendUDP c addr testMsg 29 | [(_, partial, rcvMsg)]<- recvUDP s 30 | partial @=? False 31 | rcvMsg @=? testMsg 32 | 33 | threadDelay 100000 34 | 35 | forkIO $ sendUDP c addr longMsg 36 | [(_, partial, rcvMsg)]<- recvUDP s 37 | partial @=? True 38 | 39 | it "UDP sending addr test" $ do 40 | let testMsg = V.replicate 256 48 41 | addr = SockAddrInet 12346 inetLoopback 42 | addr' = SockAddrInet 12347 inetLoopback 43 | withResource (initUDP defaultUDPConfig{localUDPAddr = Just (addr,UV_UDP_DEFAULT)}) $ \ c -> 44 | withResource (initUDP defaultUDPConfig{localUDPAddr = Just (addr',UV_UDP_DEFAULT)}) $ \ s -> do 45 | forkIO $ sendUDP c addr' testMsg 46 | [(rcvAddr, _, _)]<- recvUDP s 47 | Just addr @=? rcvAddr 48 | 49 | it "overlong message exception" $ do 50 | let testMsg = V.replicate 4096 48 51 | addr = SockAddrInet 12348 inetLoopback 52 | withResource (initUDP defaultUDPConfig) $ \ c -> 53 | withResource (initUDP defaultUDPConfig) $ \ s -> do 54 | sendUDP c addr testMsg `shouldThrow` anyException 55 | 56 | {- This test need a local broadcast address, so it's disabled by default. 57 | it "UDP sending addr test" $ do 58 | let testMsg = V.replicate 256 48 59 | addr = SockAddrInet 12349 (tupleToInetAddr (10,92,239,187)) 60 | addr' = SockAddrInet 12350 inetAny 61 | broadcastAddr = SockAddrInet 12350 (tupleToInetAddr (10,92,239,255)) 62 | withResource (initUDP defaultUDPConfig{localUDPAddr = Just (addr,UV_UDP_DEFAULT)}) $ \ c -> 63 | withResource (initUDP defaultUDPConfig{localUDPAddr = Just (addr',UV_UDP_DEFAULT)}) $ \ s -> do 64 | setBroadcast c True 65 | forkIO $ sendUDP c broadcastAddr testMsg 66 | [(rcvAddr, _, rcvMsg)]<- recvUDP s 67 | Just addr @=? rcvAddr 68 | rcvMsg @=? testMsg 69 | -} 70 | -------------------------------------------------------------------------------- /std-data/Std/Data/PrimArray/Cast.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE DefaultSignatures #-} 5 | {-# LANGUAGE MagicHash #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | 8 | {-| 9 | Module : Std.Data.PrimArray.Cast 10 | Description : Primitive casting 11 | Copyright : Haskell Foundation, (c) Dong Han, 2017-2018 12 | License : BSD 13 | Maintainer : winterland1989@gmail.com 14 | Stability : experimental 15 | Portability : non-portable 16 | 17 | This module is borrowed from basement's Cast module with conditional instances removed. The purpose of 'Cast' is to provide primitive types which share the same byte size, so that arrays and vectors parameterized by them can be safely coerced without breaking the index bounds. You can also use it to directly cast primitives just like @reinterpret_cast@. A 'Coercible' based instance is also provide for convenience. 18 | 19 | -} 20 | 21 | module Std.Data.PrimArray.Cast 22 | ( Cast(..) 23 | ) where 24 | 25 | import GHC.Prim 26 | import GHC.Types 27 | import GHC.Int 28 | import GHC.Word 29 | import GHC.IntWord64 30 | import GHC.Float 31 | import Data.Coerce 32 | 33 | #include "MachDeps.h" 34 | 35 | -- | `Cast` between primitive types of the same size. 36 | -- 37 | class Cast source destination where 38 | cast :: source -> destination 39 | 40 | instance {-# INCOHERENT #-} Coercible a b => Cast a b where 41 | cast = coerce 42 | 43 | instance Cast Int8 Word8 where 44 | cast (I8# i) = W8# (narrow8Word# (int2Word# i)) 45 | instance Cast Int16 Word16 where 46 | cast (I16# i) = W16# (narrow16Word# (int2Word# i)) 47 | instance Cast Int32 Word32 where 48 | cast (I32# i) = W32# (narrow32Word# (int2Word# i)) 49 | instance Cast Int64 Word64 where 50 | #if WORD_SIZE_IN_BITS < 64 51 | cast (I64# i) = W64# (int64ToWord64# i) 52 | #else 53 | cast (I64# i) = W64# (int2Word# i) 54 | #endif 55 | instance Cast Int Word where 56 | cast (I# i) = W# (int2Word# i) 57 | 58 | instance Cast Word8 Int8 where 59 | cast (W8# i) = I8# (narrow8Int# (word2Int# i)) 60 | instance Cast Word16 Int16 where 61 | cast (W16# i) = I16# (narrow16Int# (word2Int# i)) 62 | instance Cast Word32 Int32 where 63 | cast (W32# i) = I32# (narrow32Int# (word2Int# i)) 64 | instance Cast Word64 Int64 where 65 | #if WORD_SIZE_IN_BITS < 64 66 | cast (W64# i) = I64# (word64ToInt64# i) 67 | #else 68 | cast (W64# i) = I64# (word2Int# i) 69 | #endif 70 | instance Cast Word Int where 71 | cast (W# w) = I# (word2Int# w) 72 | 73 | instance Cast Word64 Double where 74 | cast = castWord64ToDouble 75 | instance Cast Word32 Float where 76 | cast = castWord32ToFloat 77 | instance Cast Double Word64 where 78 | cast = castDoubleToWord64 79 | instance Cast Float Word32 where 80 | cast = castFloatToWord32 81 | 82 | instance Cast Int64 Double where 83 | cast = castWord64ToDouble . cast 84 | instance Cast Int32 Float where 85 | cast = castWord32ToFloat . cast 86 | instance Cast Double Int64 where 87 | cast = cast . castDoubleToWord64 88 | instance Cast Float Int32 where 89 | cast = cast . castFloatToWord32 90 | -------------------------------------------------------------------------------- /bench/json/AutoCompare.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Main (main) where 6 | 7 | import Control.DeepSeq 8 | import Control.Monad 9 | import Criterion.Main 10 | import Data.Aeson 11 | import qualified Std.Data.JSON.Value as JSON 12 | import qualified Std.Data.JSON.Base as JSON 13 | import qualified Std.Data.Builder as B 14 | 15 | import qualified Auto.T.D as T 16 | import qualified Auto.T.BigRecord as T 17 | import qualified Auto.T.BigProduct as T 18 | import qualified Auto.T.BigSum as T 19 | import qualified Auto.G.D as G 20 | import qualified Auto.G.BigRecord as G 21 | import qualified Auto.G.BigProduct as G 22 | import qualified Auto.G.BigSum as G 23 | 24 | -------------------------------------------------------------------------------- 25 | 26 | runBench :: IO () 27 | runBench = defaultMain 28 | [ compareBench "D" T.d G.d 29 | , compareBench "BigRecord" T.bigRecord G.bigRecord 30 | , compareBench "BigProduct" T.bigProduct G.bigProduct 31 | , compareBench "BigSum" T.bigSum G.bigSum 32 | ] 33 | 34 | group :: String -> Benchmarkable -> Benchmarkable -> Benchmark 35 | group n th gen = bgroup n [ bench "th" th 36 | , bench "generic" gen 37 | ] 38 | 39 | compareBench 40 | :: forall a b 41 | . (ToJSON a, FromJSON a, NFData a, ToJSON b, FromJSON b, NFData b 42 | , JSON.ToValue b, JSON.FromValue b , JSON.EncodeJSON b) 43 | 44 | => String -> a -> b -> Benchmark 45 | compareBench name a b = v `deepseq` bgroup name 46 | [ group "toJSON" (nf toJSON a) 47 | (nf toJSON b) 48 | , bench "stdio-toJSON" (nf JSON.toValue b) 49 | , group "encode" (nf encode a) 50 | (nf encode b) 51 | , bench "stdio-encode" (nf encode' b) 52 | , group "fromJSON" (nf (fromJSON :: Value -> Result a) v) 53 | (nf (fromJSON :: Value -> Result b) v) 54 | , bench "stdio-fromJSON" (nf (JSON.convert' :: JSON.Value -> Either JSON.ConvertError b) v') 55 | ] where 56 | v = toJSON a -- == toJSON b 57 | v' = JSON.toValue b 58 | encode' = B.buildBytes . JSON.encodeJSON 59 | 60 | sanityCheck :: IO () 61 | sanityCheck = do 62 | check T.d 63 | check G.d 64 | check T.bigRecord 65 | check G.bigRecord 66 | check T.bigProduct 67 | check G.bigProduct 68 | check T.bigSum 69 | check G.bigSum 70 | 71 | check' G.d 72 | check' G.bigRecord 73 | check' G.bigProduct 74 | check' G.bigSum 75 | 76 | check :: (Show a, Eq a, FromJSON a, ToJSON a) 77 | => a -> IO () 78 | check x = do 79 | unless (Success x == (fromJSON . toJSON) x) $ fail $ "toJSON: " ++ show x 80 | unless (Success x == (decode_ . encode) x) $ fail $ "encode: " ++ show x 81 | where 82 | decode_ s = case decode s of 83 | Just v -> fromJSON v 84 | Nothing -> fail "" 85 | 86 | check' :: (Show a, Eq a, JSON.FromValue a, JSON.ToValue a, JSON.EncodeJSON a) 87 | => a -> IO () 88 | check' x = do 89 | unless (Right x == (JSON.convert' . JSON.toValue) x) $ fail $ "toValue: " ++ show x 90 | unless (Right x == (JSON.decode' . encode') x) $ fail $ "encode: " ++ show x 91 | where 92 | encode' = B.buildBytes . JSON.encodeJSON 93 | 94 | main :: IO () 95 | main = do 96 | sanityCheck 97 | runBench 98 | -------------------------------------------------------------------------------- /std-data/include/text.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2017-2018 Dong Han 3 | * 4 | * All rights reserved. 5 | * 6 | * Redistribution and use in source and binary forms, with or without 7 | * modification, are permitted provided that the following conditions 8 | * are met: 9 | * 1. Redistributions of source code must retain the above copyright 10 | * notice, this list of conditions and the following disclaimer. 11 | * 2. Redistributions in binary form must reproduce the above copyright 12 | * notice, this list of conditions and the following disclaimer in the 13 | * documentation and/or other materials provided with the distribution. 14 | * 3. Neither the names of the authors or the names of any contributors 15 | * may be used to endorse or promote products derived from this software 16 | * without specific prior written permission. 17 | * 18 | * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 19 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 22 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 24 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 25 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 26 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 27 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 28 | * SUCH DAMAGE. 29 | */ 30 | 31 | #include 32 | 33 | HsInt ascii_validate(const char* p, HsInt off, HsInt len); 34 | HsInt ascii_validate_addr(const char* p, HsInt len); 35 | HsInt utf8_validate(const char* p, HsInt off, HsInt len); 36 | HsInt utf8_validate_addr(const char* p, HsInt len); 37 | 38 | HsInt find_json_string_end(uint32_t* state, const unsigned char* ba, HsInt offset, HsInt len); 39 | HsInt decode_json_string(char *dest, const char *src, HsInt srcoff, HsInt srclen); 40 | HsInt escape_json_string_length(const unsigned char *src, HsInt srcoff, HsInt srclen); 41 | HsInt escape_json_string(const unsigned char *src, HsInt srcoff, HsInt srclen, unsigned char *dest, HsInt desoff); 42 | 43 | HsInt utf8_isnormalized(const char* p, HsInt off, HsInt len, size_t flag); 44 | HsInt utf8_normalize(const char* p, HsInt off, HsInt len, char* q, HsInt len2, size_t flag); 45 | HsInt utf8_normalize_length(const char* p, HsInt off, HsInt len, size_t flag); 46 | 47 | 48 | HsInt utf8_casefold(const char* p, HsInt off, HsInt len, char* q, HsInt len2, size_t locale); 49 | HsInt utf8_casefold_length(const char* p, HsInt off, HsInt len, size_t locale); 50 | 51 | HsInt utf8_tolower(const char* p, HsInt off, HsInt len, char* q, HsInt len2, size_t locale); 52 | HsInt utf8_tolower_length(const char* p, HsInt off, HsInt len, size_t locale); 53 | 54 | HsInt utf8_toupper(const char* p, HsInt off, HsInt len, char* q, HsInt len2, size_t locale); 55 | HsInt utf8_toupper_length(const char* p, HsInt off, HsInt len, size_t locale); 56 | 57 | HsInt utf8_totitle(const char* p, HsInt off, HsInt len, char* q, HsInt len2, size_t locale); 58 | HsInt utf8_totitle_length(const char* p, HsInt off, HsInt len, size_t locale); 59 | 60 | HsInt utf8_iscategory(const char* p, HsInt off, HsInt len, size_t flags); 61 | -------------------------------------------------------------------------------- /bench/json/json-data/example.json: -------------------------------------------------------------------------------- 1 | {"web-app": { 2 | "servlet": [ 3 | { 4 | "servlet-name": "cofaxCDS", 5 | "servlet-class": "org.cofax.cds.CDSServlet", 6 | "init-param": { 7 | "configGlossary:installationAt": "Philadelphia, PA", 8 | "configGlossary:adminEmail": "ksm@pobox.com", 9 | "configGlossary:poweredBy": "Cofax", 10 | "configGlossary:poweredByIcon": "/images/cofax.gif", 11 | "configGlossary:staticPath": "/content/static", 12 | "templateProcessorClass": "org.cofax.WysiwygTemplate", 13 | "templateLoaderClass": "org.cofax.FilesTemplateLoader", 14 | "templatePath": "templates", 15 | "templateOverridePath": "", 16 | "defaultListTemplate": "listTemplate.htm", 17 | "defaultFileTemplate": "articleTemplate.htm", 18 | "useJSP": false, 19 | "jspListTemplate": "listTemplate.jsp", 20 | "jspFileTemplate": "articleTemplate.jsp", 21 | "cachePackageTagsTrack": 200, 22 | "cachePackageTagsStore": 200, 23 | "cachePackageTagsRefresh": 60, 24 | "cacheTemplatesTrack": 100, 25 | "cacheTemplatesStore": 50, 26 | "cacheTemplatesRefresh": 15, 27 | "cachePagesTrack": 200, 28 | "cachePagesStore": 100, 29 | "cachePagesRefresh": 10, 30 | "cachePagesDirtyRead": 10, 31 | "searchEngineListTemplate": "forSearchEnginesList.htm", 32 | "searchEngineFileTemplate": "forSearchEngines.htm", 33 | "searchEngineRobotsDb": "WEB-INF/robots.db", 34 | "useDataStore": true, 35 | "dataStoreClass": "org.cofax.SqlDataStore", 36 | "redirectionClass": "org.cofax.SqlRedirection", 37 | "dataStoreName": "cofax", 38 | "dataStoreDriver": "com.microsoft.jdbc.sqlserver.SQLServerDriver", 39 | "dataStoreUrl": "jdbc:microsoft:sqlserver://LOCALHOST:1433;DatabaseName=goon", 40 | "dataStoreUser": "sa", 41 | "dataStorePassword": "dataStoreTestQuery", 42 | "dataStoreTestQuery": "SET NOCOUNT ON;select test='test';", 43 | "dataStoreLogFile": "/usr/local/tomcat/logs/datastore.log", 44 | "dataStoreInitConns": 10, 45 | "dataStoreMaxConns": 100, 46 | "dataStoreConnUsageLimit": 100, 47 | "dataStoreLogLevel": "debug", 48 | "maxUrlLength": 500}}, 49 | { 50 | "servlet-name": "cofaxEmail", 51 | "servlet-class": "org.cofax.cds.EmailServlet", 52 | "init-param": { 53 | "mailHost": "mail1", 54 | "mailHostOverride": "mail2"}}, 55 | { 56 | "servlet-name": "cofaxAdmin", 57 | "servlet-class": "org.cofax.cds.AdminServlet"}, 58 | 59 | { 60 | "servlet-name": "fileServlet", 61 | "servlet-class": "org.cofax.cds.FileServlet"}, 62 | { 63 | "servlet-name": "cofaxTools", 64 | "servlet-class": "org.cofax.cms.CofaxToolsServlet", 65 | "init-param": { 66 | "templatePath": "toolstemplates/", 67 | "log": 1, 68 | "logLocation": "/usr/local/tomcat/logs/CofaxTools.log", 69 | "logMaxSize": "", 70 | "dataLog": 1, 71 | "dataLogLocation": "/usr/local/tomcat/logs/dataLog.log", 72 | "dataLogMaxSize": "", 73 | "removePageCache": "/content/admin/remove?cache=pages&id=", 74 | "removeTemplateCache": "/content/admin/remove?cache=templates&id=", 75 | "fileTransferFolder": "/usr/local/tomcat/webapps/content/fileTransferFolder", 76 | "lookInContext": 1, 77 | "adminGroupID": 4, 78 | "betaServer": true}}], 79 | "servlet-mapping": { 80 | "cofaxCDS": "/", 81 | "cofaxEmail": "/cofaxutil/aemail/*", 82 | "cofaxAdmin": "/admin/*", 83 | "fileServlet": "/static/*", 84 | "cofaxTools": "/tools/*"}, 85 | 86 | "taglib": { 87 | "taglib-uri": "cofax.tld", 88 | "taglib-location": "/WEB-INF/tlds/cofax.tld"}}} 89 | -------------------------------------------------------------------------------- /bench/data/Builder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module Builder (builder) where 7 | 8 | import Criterion.Main 9 | import qualified Data.ByteString as BS 10 | import qualified Data.ByteString.Builder as BB 11 | import qualified Data.ByteString.Lazy as BL 12 | import qualified Std.Data.Builder as B 13 | import qualified Std.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 | 20 | bytestring1000 :: BS.ByteString 21 | bytestring1000 = BS.replicate 1000 0 22 | 23 | bytes1000 :: V.Bytes 24 | bytes1000 = V.replicate 1000 0 25 | 26 | bytestring20000 :: BS.ByteString 27 | bytestring20000 = BS.replicate 20000 0 28 | 29 | bytes20000 :: V.Bytes 30 | bytes20000 = V.replicate 20000 0 31 | 32 | builder :: [Benchmark] 33 | builder = 34 | [ bgroup "word8 100000000" word8_100000000 35 | , bgroup "word8 10000" word8_10000 36 | , bgroup "word8 32" word8_32 37 | , bgroup "bytestring/bytes 32 * 1000" bytes_32_1000 38 | , bgroup "bytestring/bytes 32 * 20000" bytes_32_20000 39 | ] 40 | 41 | word8_100000000 :: [Benchmark] 42 | word8_100000000 = 43 | [ bench "bytestring/toLazyByteString" $ nf BB.toLazyByteString (mconcat (replicate 100000000 (BB.word8 123))) 44 | , bench "bytestring/toStrict . toLazyByteString" $ nf (BL.toStrict . BB.toLazyByteString) (mconcat (replicate 100000000 (BB.word8 123))) 45 | , bench "stdio/buildBytesList" $ nf B.buildBytesList (mconcat (replicate 100000000 (B.encodePrim @Word8 123))) 46 | , bench "stdio/buildBytes" $ nf B.buildBytes (mconcat (replicate 100000000 (B.encodePrim @Word8 123))) 47 | , bench "stdio/buildAndRun" $ nfIO (B.buildAndRun (void . evaluate) (mconcat (replicate 100000000 (B.encodePrim @Word8 123)))) 48 | ] 49 | 50 | word8_10000 :: [Benchmark] 51 | word8_10000 = 52 | [ bench "bytestring/toLazyByteString" $ nf BB.toLazyByteString (mconcat (replicate 10000 (BB.word8 123))) 53 | , bench "bytestring/toStrict . toLazyByteString" $ nf (BL.toStrict . BB.toLazyByteString) (mconcat (replicate 10000 (BB.word8 123))) 54 | , bench "stdio/buildBytesList" $ nf B.buildBytesList (mconcat (replicate 10000 (B.encodePrim @Word8 123))) 55 | , bench "stdio/buildBytes" $ nf B.buildBytes (mconcat (replicate 10000 (B.encodePrim @Word8 123))) 56 | , bench "stdio/buildAndRun" $ nfIO (B.buildAndRun (void . evaluate) (mconcat (replicate 10000 (B.encodePrim @Word8 123)))) 57 | ] 58 | 59 | word8_32 :: [Benchmark] 60 | word8_32 = 61 | [ bench "bytestring/toLazyByteString" $ nf BB.toLazyByteString (mconcat (replicate 32 (BB.word8 123))) 62 | , bench "bytestring/toStrict . toLazyByteString" $ nf (BL.toStrict . BB.toLazyByteString) (mconcat (replicate 32 (BB.word8 123))) 63 | , bench "stdio/buildBytesList" $ nf B.buildBytesList (mconcat (replicate 32 (B.encodePrim @Word8 123))) 64 | , bench "stdio/buildBytes" $ nf B.buildBytes (mconcat (replicate 32 (B.encodePrim @Word8 123))) 65 | , bench "stdio/buildAndRun" $ nfIO (B.buildAndRun (void . evaluate) (mconcat (replicate 32 (B.encodePrim @Word8 123)))) 66 | ] 67 | 68 | bytes_32_1000 :: [Benchmark] 69 | bytes_32_1000 = 70 | [ bench "bytestring/toLazyByteString" $ nf BB.toLazyByteString 71 | (mconcat (replicate 32 $ BB.byteString bytestring1000)) 72 | , bench "stdio/buildBytesList" $ nf B.buildBytesList (mconcat (replicate 32 (B.bytes bytes1000))) 73 | , bench "stdio/buildAndRun" $ nfIO (B.buildAndRun (void . evaluate) (mconcat (replicate 32 (B.bytes bytes1000)))) 74 | ] 75 | 76 | bytes_32_20000 :: [Benchmark] 77 | bytes_32_20000 = 78 | [ bench "bytestring/toLazyByteString" $ nf BB.toLazyByteString 79 | (mconcat (replicate 32 $ BB.byteString bytestring20000)) 80 | , bench "stdio/buildBytesList" $ nf B.buildBytesList (mconcat (replicate 32 (B.bytes bytes20000))) 81 | , bench "stdio/buildAndRun" $ nfIO (B.buildAndRun (void . evaluate) (mconcat (replicate 32 (B.bytes bytes20000)))) 82 | ] 83 | 84 | -------------------------------------------------------------------------------- /std-data/Std/Data/Text.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash, UnboxedTuples #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE UnliftedFFITypes #-} 4 | {-# LANGUAGE DeriveDataTypeable #-} 5 | {-# LANGUAGE PatternSynonyms #-} 6 | 7 | {-| 8 | Module : Std.Data.Text 9 | Description : Unicode text processing 10 | Copyright : (c) Dong Han, 2017-2018 11 | License : BSD 12 | Maintainer : winterland1989@gmail.com 13 | Stability : experimental 14 | Portability : non-portable 15 | 16 | A 'Text' simply wraps a 'Bytes' that are UTF-8 encoded codepoints, you can use 'validate' \/ 'validateMaybe' to construct a 'Text'. 17 | 18 | -} 19 | 20 | module Std.Data.Text ( 21 | -- * Text type 22 | Text, getUTF8Bytes 23 | , validate, validateMaybe 24 | -- * Basic creating 25 | , empty, singleton, copy 26 | -- * Building text 27 | , replicate, cycleN 28 | -- * Conversion between list 29 | , pack, packN, packR, packRN 30 | , unpack, unpackR 31 | -- * Conversion between codepoint vector 32 | , fromVector 33 | , toVector 34 | -- * Basic interface 35 | , null 36 | , length 37 | , append 38 | , map', imap' 39 | , foldl', ifoldl' 40 | , foldr', ifoldr' 41 | , concat, concatMap 42 | -- ** Special folds 43 | , count, all, any 44 | -- * Searching by equality 45 | , elem, notElem 46 | -- * Slice manipulation 47 | , cons, snoc 48 | , uncons, unsnoc 49 | , headMaybe, tailMayEmpty 50 | , lastMaybe, initMayEmpty 51 | , inits, tails 52 | , take, drop, takeR, dropR 53 | , slice 54 | , splitAt 55 | , takeWhile, takeWhileR, dropWhile, dropWhileR, dropAround 56 | , break, span 57 | , breakR, spanR, breakOn, breakOnAll 58 | , group, groupBy 59 | , stripPrefix, stripSuffix 60 | , split, splitWith, splitOn 61 | , isPrefixOf, isSuffixOf, isInfixOf 62 | , commonPrefix 63 | , words, lines, unwords, unlines 64 | , padLeft, padRight 65 | -- * Transform 66 | , reverse 67 | , intersperse 68 | , intercalate 69 | , intercalateElem 70 | , transpose 71 | -- * Search 72 | -- ** element-wise search 73 | , find, findR 74 | , filter, partition 75 | -- * Unicode processing 76 | -- ** normalization 77 | , NormalizationResult(..), NormalizeMode(..) 78 | , isNormalized, isNormalizedTo, normalize, normalizeTo 79 | -- ** Case conversion 80 | -- $case 81 | , Locale, localeDefault, localeLithuanian, localeTurkishAndAzeriLatin 82 | , caseFold, caseFoldWith, toLower, toLowerWith, toUpper, toUpperWith, toTitle, toTitleWith 83 | -- ** Unicode category 84 | , isCategory, spanCategory 85 | , Category 86 | , categoryLetterUppercase 87 | , categoryLetterLowercase 88 | , categoryLetterTitlecase 89 | , categoryLetterOther 90 | , categoryLetter 91 | , categoryCaseMapped 92 | 93 | , categoryMarkNonSpacing 94 | , categoryMarkSpacing 95 | , categoryMarkEnclosing 96 | , categoryMark 97 | 98 | , categoryNumberDecimal 99 | , categoryNumberLetter 100 | , categoryNumberOther 101 | , categoryNumber 102 | 103 | , categoryPunctuationConnector 104 | , categoryPunctuationDash 105 | , categoryPunctuationOpen 106 | , categoryPunctuationClose 107 | , categoryPunctuationInitial 108 | , categoryPunctuationFinal 109 | , categoryPunctuationOther 110 | , categoryPunctuation 111 | 112 | , categorySymbolMath 113 | , categorySymbolCurrency 114 | , categorySymbolModifier 115 | , categorySymbolOther 116 | , categorySymbol 117 | 118 | , categorySeparatorSpace 119 | , categorySeparatorLine 120 | , categorySeparatorParagraph 121 | , categorySeparator 122 | , categoryControl 123 | , categoryFormat 124 | , categorySurrogate 125 | , categoryPrivateUse 126 | , categoryUnassigned 127 | , categoryCompatibility 128 | , categoryIgnoreGraphemeCluste 129 | , categoryIscntrl 130 | 131 | , categoryIsprint 132 | , categoryIsspace 133 | , categoryIsblank 134 | , categoryIsgraph 135 | , categoryIspunct 136 | , categoryIsalnum 137 | , categoryIsalpha 138 | , categoryIsupper 139 | , categoryIslower 140 | , categoryIsdigit 141 | , categoryIsxdigit 142 | ) where 143 | 144 | import Std.Data.Text.Base 145 | import Std.Data.Text.Search 146 | import Std.Data.Text.Extra 147 | import Prelude () 148 | 149 | 150 | -------------------------------------------------------------------------------- /bench/parser/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | 4 | module Main where 5 | 6 | import Data.Serialize.Get 7 | import qualified Data.Binary.Get as G 8 | import qualified Data.Attoparsec.ByteString as AP 9 | import qualified Data.Attoparsec.Internal as AP 10 | import qualified Data.Store.Core as C 11 | import Data.Word 12 | import qualified Data.ByteString as B 13 | import qualified Data.ByteString.Lazy as BL 14 | import Std.Data.Parser 15 | -- import qualified Std.Data.Decoder.Base as Dec 16 | import qualified Std.Data.Vector.Base as V 17 | import Control.Monad 18 | import qualified Foreign.Ptr as AP (castPtr, minusPtr, plusPtr) 19 | import qualified Foreign.ForeignPtr as AP (withForeignPtr) 20 | import qualified Foreign.Storable as AP (Storable(peek, sizeOf)) 21 | import qualified Data.ByteString.Internal as B 22 | 23 | storable :: AP.Storable a => AP.Parser a 24 | {-# INLINE storable #-} 25 | storable = hack undefined 26 | where 27 | hack :: AP.Storable b => b -> AP.Parser b 28 | hack dummy = do 29 | (fp,o,_) <- B.toForeignPtr `fmap` AP.take (AP.sizeOf dummy) 30 | return . B.inlinePerformIO . AP.withForeignPtr fp $ \p -> 31 | AP.peek (AP.castPtr $ p `AP.plusPtr` o) 32 | 33 | data Test = Test 34 | {-# UNPACK #-} !Word16 35 | {-# UNPACK #-} !Word16 36 | {-# UNPACK #-} !Word16 37 | {-# UNPACK #-} !Word16 38 | {-# UNPACK #-} !Word16 39 | {-# UNPACK #-} !Word16 40 | deriving Show 41 | 42 | {- 43 | decTest :: Dec.Decoder Test 44 | decTest = Test <$> Dec.decodePrim 45 | <*> Dec.decodePrim 46 | <*> Dec.decodePrim 47 | <*> Dec.decodePrim 48 | <*> Dec.decodePrim 49 | <*> Dec.decodePrim 50 | -} 51 | 52 | apTest :: AP.Parser Test 53 | apTest = Test <$> storable 54 | <*> storable 55 | <*> storable 56 | <*> storable 57 | <*> storable 58 | <*> storable 59 | 60 | getTest :: Get Test 61 | getTest = Test <$> getWord16le 62 | <*> getWord16le 63 | <*> getWord16le 64 | <*> getWord16le 65 | <*> getWord16le 66 | <*> getWord16le 67 | 68 | getTest' :: G.Get Test 69 | getTest' = Test <$> G.getWord16le 70 | <*> G.getWord16le 71 | <*> G.getWord16le 72 | <*> G.getWord16le 73 | <*> G.getWord16le 74 | <*> G.getWord16le 75 | 76 | peekTest :: C.Peek Test 77 | peekTest = Test <$> C.peekStorable 78 | <*> C.peekStorable 79 | <*> C.peekStorable 80 | <*> C.peekStorable 81 | <*> C.peekStorable 82 | <*> C.peekStorable 83 | 84 | decodeTest' :: Parser Test 85 | decodeTest' = Test <$> decodePrimLE 86 | <*> decodePrimLE 87 | <*> decodePrimLE 88 | <*> decodePrimLE 89 | <*> decodePrimLE 90 | <*> decodePrimLE 91 | 92 | main :: IO () 93 | main = do 94 | print "Store start" 95 | forM_ [0..10] $ \ i -> do 96 | let !b = B.replicate 120000000 (fromIntegral i) 97 | print $ last $ C.decodeExWith (replicateM 10000000 peekTest) b 98 | print "Store end" 99 | {- 100 | print "Decoder start" 101 | forM_ [0..10] $ \ i -> do 102 | let !b = V.replicate 120000000 (fromIntegral i) 103 | print $ last $ Dec.decode (replicateM 10000000 decTest) b 104 | print "Decoder end" 105 | -} 106 | print "Std.Data.Parser start" 107 | forM_ [0..10] $ \ i -> do 108 | let !v = V.replicate 120000000 (fromIntegral i) 109 | print $ last <$> parse_ (replicateM 10000000 decodeTest') v 110 | print "Std.Data.Parser end" 111 | print "attoparsec start" 112 | forM_ [0..10] $ \ i -> do 113 | let !b = B.replicate 120000000 (fromIntegral i) 114 | print $ last <$> AP.parseOnly (replicateM 10000000 apTest) b 115 | print "attoparsec end" 116 | print "Cereal start" 117 | forM_ [0..10] $ \ i -> do 118 | let !b = B.replicate 120000000 (fromIntegral i) 119 | print $ last <$> runGet (replicateM 10000000 getTest) b 120 | print "Cereal end" 121 | print "Binary start" 122 | forM_ [0..10] $ \ i -> do 123 | let !b = B.replicate 120000000 (fromIntegral i) 124 | print $ last $ G.runGet (replicateM 10000000 getTest') (BL.fromStrict b) 125 | print "Binary end" 126 | -------------------------------------------------------------------------------- /std-data/Std/Data/Vector/QQ.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE MagicHash #-} 4 | 5 | {-| 6 | Module : Std.Data.Vector.QQ 7 | Description : vectors literals using QuasiQuote 8 | Copyright : (c) Dong Han, 2017-2018 9 | License : BSD 10 | Maintainer : winterland1989@gmail.com 11 | Stability : experimental 12 | Portability : non-portable 13 | 14 | This module provides functions for writing vector literals using 'QuasiQuote'. 15 | 16 | -} 17 | 18 | module Std.Data.Vector.QQ ( 19 | -- * QuasiQuoters 20 | ascii 21 | , vecW8, vecW16, vecW32, vecW64, vecWord 22 | , vecI8, vecI16, vecI32, vecI64, vecInt 23 | ) where 24 | 25 | import qualified Language.Haskell.TH.Quote as QQ 26 | import Std.Data.PrimArray.QQ as QQ 27 | import Std.Data.Vector.Base 28 | 29 | -------------------------------------------------------------------------------- 30 | -- Quoters 31 | 32 | ascii :: QQ.QuasiQuoter 33 | ascii = QQ.QuasiQuoter 34 | (asciiLiteral $ \ len addr -> [| PrimVector (QQ.word8ArrayFromAddr $(len) $(addr)) 0 $(len) |]) 35 | (error "Cannot use ascii as a pattern") 36 | (error "Cannot use ascii as a type") 37 | (error "Cannot use ascii as a dec") 38 | 39 | vecW8 :: QQ.QuasiQuoter 40 | vecW8 = QQ.QuasiQuoter 41 | (QQ.word8Literal $ \ len addr -> [| PrimVector (QQ.word8ArrayFromAddr $(len) $(addr)) 0 $(len) |]) 42 | (error "Cannot use vecW8 as a pattern") 43 | (error "Cannot use vecW8 as a type") 44 | (error "Cannot use vecW8 as a dec") 45 | 46 | vecW16 :: QQ.QuasiQuoter 47 | vecW16 = QQ.QuasiQuoter 48 | (QQ.word16Literal $ \ len addr -> [| PrimVector (QQ.word16ArrayFromAddr $(len) $(addr)) 0 $(len) |]) 49 | (error "Cannot use vecW16 as a pattern") 50 | (error "Cannot use vecW16 as a type") 51 | (error "Cannot use vecW16 as a dec") 52 | 53 | vecW32 :: QQ.QuasiQuoter 54 | vecW32 = QQ.QuasiQuoter 55 | (QQ.word32Literal $ \ len addr -> [| PrimVector (QQ.word32ArrayFromAddr $(len) $(addr)) 0 $(len) |]) 56 | (error "Cannot use vecW32 as a pattern") 57 | (error "Cannot use vecW32 as a type") 58 | (error "Cannot use vecW32 as a dec") 59 | 60 | vecW64 :: QQ.QuasiQuoter 61 | vecW64 = QQ.QuasiQuoter 62 | (QQ.word64Literal $ \ len addr -> [| PrimVector (QQ.word64ArrayFromAddr $(len) $(addr)) 0 $(len) |]) 63 | (error "Cannot use vecW64 as a pattern") 64 | (error "Cannot use vecW64 as a type") 65 | (error "Cannot use vecW64 as a dec") 66 | 67 | vecWord :: QQ.QuasiQuoter 68 | vecWord = QQ.QuasiQuoter 69 | (QQ.wordLiteral $ \ len addr -> 70 | [| PrimVector (QQ.wordArrayFromAddr $(len) $(addr)) 0 $(len) |]) 71 | (error "Cannot use vecWord as a pattern") 72 | (error "Cannot use vecWord as a type") 73 | (error "Cannot use vecWord as a dec") 74 | 75 | vecI8 :: QQ.QuasiQuoter 76 | vecI8 = QQ.QuasiQuoter 77 | (QQ.int8Literal $ \ len addr -> 78 | [| PrimVector (QQ.int8ArrayFromAddr $(len) $(addr)) 0 $(len) |]) 79 | (error "Cannot use vecI8 as a pattern") 80 | (error "Cannot use vecI8 as a type") 81 | (error "Cannot use vecI8 as a dec") 82 | 83 | vecI16 :: QQ.QuasiQuoter 84 | vecI16 = QQ.QuasiQuoter 85 | (QQ.int16Literal $ \ len addr -> 86 | [| PrimVector (QQ.int16ArrayFromAddr $(len) $(addr)) 0 $(len) |]) 87 | (error "Cannot use vecI16 as a pattern") 88 | (error "Cannot use vecI16 as a type") 89 | (error "Cannot use vecI16 as a dec") 90 | 91 | vecI32 :: QQ.QuasiQuoter 92 | vecI32 = QQ.QuasiQuoter 93 | (QQ.int32Literal $ \ len addr -> 94 | [| PrimVector (QQ.int32ArrayFromAddr $(len) $(addr)) 0 $(len) |]) 95 | (error "Cannot use vecI32 as a pattern") 96 | (error "Cannot use vecI32 as a type") 97 | (error "Cannot use vecI32 as a dec") 98 | 99 | vecI64 :: QQ.QuasiQuoter 100 | vecI64 = QQ.QuasiQuoter 101 | (QQ.int64Literal $ \ len addr -> 102 | [| PrimVector (QQ.int64ArrayFromAddr $(len) $(addr)) 0 $(len) |]) 103 | (error "Cannot use vecI64 as a pattern") 104 | (error "Cannot use vecI64 as a type") 105 | (error "Cannot use vecI64 as a dec") 106 | 107 | vecInt :: QQ.QuasiQuoter 108 | vecInt = QQ.QuasiQuoter 109 | (QQ.intLiteral $ \ len addr -> 110 | [| PrimVector (QQ.intArrayFromAddr $(len) $(addr)) 0 $(len) |]) 111 | (error "Cannot use vecInt as a pattern") 112 | (error "Cannot use vecInt as a type") 113 | (error "Cannot use vecInt as a dec") 114 | 115 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Haskell stdio: haskell standard input and output 2 | ================================================ 3 | 4 | **This project is moved to [project Z](https://github.com/haskell-Z/Z) and split into several packages**. 5 | 6 | [![Linux Build Status](https://img.shields.io/travis/haskell-stdio/stdio/master.svg?label=Linux%20build)](https://travis-ci.org/haskell-stdio/stdio) 7 | [![Windows Build Status](https://img.shields.io/appveyor/ci/winterland1989/stdio-7usux/master.svg?label=Windows%20build)](https://ci.appveyor.com/project/winterland1989/stdio-7usux/branch/master) 8 | 9 | Welcome! Haskell stdio is a complete I/O toolkit powered by libuv, it features a multi-core io multiplexer and various improvements on packed data types. This project is still in infancy. Please join in! 10 | 11 | ``` 12 | __ _____ _____ __ __ ________ __ _______________ ________ 13 | / / / / | / ___// //_// ____/ / / / / ___/_ __/ __ \/ _/ __ \ 14 | / /_/ / /| | \__ \/ ,< / __/ / / / / \__ \ / / / / / // // / / / 15 | / __ / ___ |___/ / /| |/ /___/ /___/ /___ ___/ // / / /_/ // // /_/ / 16 | /_/ /_/_/ |_/____/_/ |_/_____/_____/_____/ /____//_/ /_____/___/\____/ 17 | ``` 18 | 19 | Install 20 | ------- 21 | 22 | On windows we have bundled libuv source, so no extra steps to be taken. 23 | 24 | On \*nix platforms, you should install libuv library first, you can use your distribution's package manager if available, for example: 25 | 26 | ``` 27 | # on debian/ubuntu, make sure to use 1.x 28 | apt-get install libuv1-dev libuv1 29 | 30 | # on MacOS, we recommend brew 31 | brew install libuv 32 | 33 | ... 34 | ``` 35 | 36 | Currently **the minimum version requirement for libuv is v1.14**. If your package manager's libuv doesn't meet this requirement, you can also build libuv from source following the guide [here](https://github.com/libuv/libuv#build-instructions), e.g. 37 | 38 | ``` 39 | git clone https://github.com/libuv/libuv.git 40 | cd libuv 41 | git checkout tags/v1.24.0 # depend on your own need, any version >= 1.14 will work. 42 | sh autogen.sh 43 | ./configure 44 | make 45 | sudo make install 46 | ``` 47 | 48 | After manually building and installing, you may need to modify your `LIBRARY_PATH/CPATH` if necessary. Now installing stdio is as easy as any other haskell packages. 49 | 50 | ``` 51 | cabal install stdio 52 | ``` 53 | 54 | Now you can fire GHCi and play around, or read the [project overview](https://haskell-stdio.github.io/stdio), [haddock](http://hackage.haskell.org/package/stdio). 55 | 56 | Examples 57 | -------- 58 | 59 | + hello world 60 | 61 | ``` 62 | import Std.IO.StdStream 63 | import qualified Std.Data.Text as T 64 | 65 | main = do 66 | -- read stdin and write to stdout, but with our new IO manager! 67 | input <- readLineStd 68 | printStd (T.validate input) 69 | ``` 70 | 71 | + tcp echo server 72 | 73 | ``` 74 | import Std.IO.TCP 75 | import Std.IO.Buffered 76 | import Control.Monad 77 | 78 | main = do 79 | startServer defaultServerConfig 80 | { serverAddr = SockAddrInet 8888 inetAny 81 | , serverWorker = echo 82 | } 83 | where 84 | echo uvs = forever $ do 85 | i <- newBufferedInput uvs 4096 86 | o <- newBufferedOutput uvs 4096 87 | readBuffer i >>= writeBuffer o 88 | flushBuffer o 89 | ``` 90 | 91 | Now try `nc -v 127.0.0.1 8888`. 92 | 93 | + logging 94 | 95 | ``` 96 | import Std.IO.Logger 97 | import qualified Std.Data.Builder as B 98 | import Control.Concurrent 99 | 100 | main = withStdLogger $ do 101 | debug $ "hello world! PI ~=" >> B.double pi -- debug level won't be immediately flushed 102 | forkIO $ do 103 | fatal "fatal message will trigger a log flush" 104 | ``` 105 | 106 | + file system operatations 107 | 108 | ``` 109 | import Std.IO.FileSystem 110 | import Std.IO.Resource 111 | import Std.IO.StdStream 112 | 113 | main = do 114 | -- create a temp directory 115 | tempdir <- mkdtemp "temp" 116 | let filename = "temp" <> "/test" 117 | flags = O_RDWR .|. O_CREAT -- create if not exist 118 | mode = DEFAULT_MODE 119 | 120 | -- file is a 'Resource', use 'withResource' to automatically manage it 121 | withResource (initUVFile filename flags mode) $ \ f -> do 122 | o <- newBufferedOutput file 4096 123 | writeBuffer o "hello world!" 124 | flushBuffer o 125 | 126 | stat filename >>= printStd 127 | ``` 128 | -------------------------------------------------------------------------------- /std-data/Std/Data/JSON/Builder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE MagicHash #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE UnliftedFFITypes #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | 10 | {-| 11 | Module : Std.Data.JSON.Builder 12 | Description : JSON representation and builders 13 | Copyright : (c) Dong Han, 2019 14 | License : BSD 15 | Maintainer : winterland1989@gmail.com 16 | Stability : experimental 17 | Portability : non-portable 18 | 19 | This module provides builders for JSON 'Value's, a Haskell JSON representation. These builders are designed to comply with . Only control characters are escaped, other unicode codepoints are directly written instead of being escaped. 20 | 21 | -} 22 | module Std.Data.JSON.Builder 23 | ( -- * Value Builders 24 | value 25 | , object 26 | , object' 27 | , array 28 | , array' 29 | , string 30 | -- * Builder helpers 31 | , kv, kv' 32 | -- * Re-export 'Value' type 33 | , Value(..) 34 | ) where 35 | 36 | import Control.Monad 37 | import Control.Monad.ST.Unsafe (unsafeIOToST) 38 | import Data.Primitive.PrimArray 39 | import Data.Word 40 | import GHC.Prim (unsafeCoerce#) 41 | import qualified Std.Data.Builder as B 42 | import qualified Std.Data.Builder.Base as B 43 | import qualified Std.Data.Text as T 44 | import qualified Std.Data.Text.Base as T 45 | import Std.Data.Vector.Base as V 46 | import Std.Foreign.PrimArray 47 | import Std.Data.JSON.Value (Value(..)) 48 | 49 | #define DOUBLE_QUOTE 34 50 | 51 | -- | Use @:@ as separator to connect a label(no need to escape, only add quotes) with field builders. 52 | kv :: T.Text -> B.Builder () -> B.Builder () 53 | {-# INLINE kv #-} 54 | l `kv` b = B.quotes (B.text l) >> B.colon >> b 55 | 56 | -- | Use @:@ as separator to connect a label(escaped and add quotes) with field builders. 57 | kv' :: T.Text -> B.Builder () -> B.Builder () 58 | {-# INLINE kv' #-} 59 | l `kv'` b = string l >> B.colon >> b 60 | 61 | -- | Encode a 'Value', you can use this function with 'toValue' to get 'encodeJSON' with a small overhead. 62 | value :: Value -> B.Builder () 63 | {-# INLINABLE value #-} 64 | value (Object kvs) = object kvs 65 | value (Array vs) = array vs 66 | value (String t) = string t 67 | value (Number n) = B.scientific n 68 | value (Bool True) = "true" 69 | value (Bool False) = "false" 70 | value Null = "null" 71 | 72 | array :: V.Vector Value -> B.Builder () 73 | {-# INLINE array #-} 74 | array = B.square . B.intercalateVec B.comma value 75 | 76 | array' :: (a -> B.Builder ()) -> V.Vector a -> B.Builder () 77 | {-# INLINE array' #-} 78 | array' f = B.square . B.intercalateVec B.comma f 79 | 80 | object :: V.Vector (T.Text, Value) -> B.Builder () 81 | {-# INLINE object #-} 82 | object = B.curly . B.intercalateVec B.comma (\ (k, v) -> k `kv'` value v) 83 | 84 | object' :: (a -> B.Builder ()) -> V.Vector (T.Text, a) -> B.Builder () 85 | {-# INLINE object' #-} 86 | object' f = B.curly . B.intercalateVec B.comma (\ (k, v) -> k `kv'` f v) 87 | 88 | -- | Escape text into JSON string and add double quotes, escaping rules: 89 | -- 90 | -- @ 91 | -- \'\\b\': \"\\b\" 92 | -- \'\\f\': \"\\f\" 93 | -- \'\\n\': \"\\n\" 94 | -- \'\\r\': \"\\r\" 95 | -- \'\\t\': \"\\t\" 96 | -- \'\"\': \"\\\"\" 97 | -- \'\\\': \"\\\\\" 98 | -- \'\/\': \"\\/\" 99 | -- other chars <= 0x1F: "\\u00XX" 100 | -- @ 101 | -- 102 | string :: T.Text -> B.Builder () 103 | {-# INLINE string #-} 104 | string (T.Text (V.PrimVector ba@(PrimArray ba#) s l)) = do 105 | let siz = escape_json_string_length ba# s l 106 | B.ensureN siz 107 | B.Builder (\ _ k (B.Buffer mba@(MutablePrimArray mba#) i) -> do 108 | if siz == l+2 -- no need to escape 109 | then do 110 | writePrimArray mba i DOUBLE_QUOTE 111 | copyPrimArray mba (i+1) ba s l 112 | writePrimArray mba (i+1+l) DOUBLE_QUOTE 113 | else void $ unsafeIOToST (escape_json_string ba# s l (unsafeCoerce# mba#) i) 114 | k () (B.Buffer mba (i+siz))) 115 | 116 | foreign import ccall unsafe escape_json_string_length 117 | :: BA# Word8 -> Int -> Int -> Int 118 | 119 | foreign import ccall unsafe escape_json_string 120 | :: BA# Word8 -> Int -> Int -> MBA# Word8 -> Int -> IO Int 121 | -------------------------------------------------------------------------------- /std-data/test/Std/Data/Text/BaseSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Std.Data.Text.BaseSpec where 6 | 7 | import qualified Data.List as List 8 | import Data.Word 9 | import qualified Std.Data.Text.Base as T 10 | import Test.QuickCheck 11 | import Test.QuickCheck.Function 12 | import Test.QuickCheck.Property 13 | import Test.Hspec 14 | import Test.Hspec.QuickCheck 15 | 16 | spec :: Spec 17 | spec = describe "text-base" $ do 18 | describe "text Eq Ord property" $ do 19 | prop "text eq === List.eq" $ \ xs ys -> 20 | (T.pack xs == T.pack ys) === (xs == ys) 21 | 22 | prop "text compare === List.compare" $ \ xs ys -> 23 | (T.pack xs `compare` T.pack ys) === (xs `compare` ys) 24 | 25 | describe "text unpack(R) . pack(R)(N) == id/reverse" . modifyMaxSuccess (*50) . modifyMaxSize (*50) $ do 26 | prop "unpack . pack === id" $ \ xs -> 27 | (T.unpack (T.pack xs)) === xs 28 | 29 | prop "unpackR . pack === reverse" $ \ xs -> 30 | (T.unpackR (T.pack xs)) === reverse xs 31 | 32 | prop "unpack . packR === reverse" $ \ xs -> 33 | (T.unpack (T.packR xs)) === reverse xs 34 | 35 | prop "unpackR . packR === id" $ \ xs -> 36 | (T.unpackR (T.packR xs)) === xs 37 | 38 | describe "text pack == packN" . modifyMaxSuccess (*50) . modifyMaxSize (*50) $ do 39 | prop "pack === packN XX" $ \ xs d -> 40 | (T.pack xs) === (T.packN d xs) 41 | 42 | prop "packR === packRN XX" $ \ xs d -> 43 | (T.packR xs) === (T.packRN d xs) 44 | 45 | describe "Text IsString instance property" $ do 46 | prop "ASCII string" $ 47 | "hello world" === T.pack "hello world" 48 | prop "UTF8 string" $ 49 | "你好世界" === T.pack "你好世界" 50 | prop "NUL codepoint" $ 51 | "你好\NUL世界" === T.pack "你好\NUL世界" 52 | prop "surrogate codepoint" $ 53 | "你好\xFFFD世界" === T.pack "你好\xD800世界" 54 | prop "surrogate codepoint2" $ 55 | "你好\xD800世界" === T.pack "你好\xD800世界" 56 | 57 | describe "text length == List.length" $ do 58 | prop "text length === List.length" $ \ xs -> 59 | (T.length $ T.pack xs) === List.length xs 60 | 61 | describe "text append == List.(++)" $ do 62 | prop "text eq === List.eq" $ \ xs ys -> 63 | (T.unpack $ T.pack xs `T.append` T.pack ys) === (xs ++ ys) 64 | 65 | describe "text map' == List.map" $ do 66 | prop "text map' === List.map" $ \ xs (Fun _ f) -> 67 | (T.map' f (T.pack xs)) === (T.pack $ List.map f xs) 68 | 69 | describe "text imap' (const f) == List.map f" $ do 70 | prop "text imap' (const f) == List.map f" $ \ xs (Fun _ f) -> 71 | (T.imap' (const f) $ T.pack xs) === (T.pack $ List.map f xs) 72 | 73 | describe "text imap' const == List.zipWith const [0..]" $ do 74 | prop "text imap' const == List.zipWith const [0..]" $ \ xs -> 75 | (T.imap' (\ i _ -> toEnum i) $ T.pack xs) === (T.pack . List.map toEnum $ List.zipWith const [0..] xs) 76 | 77 | describe "text foldl' == List.foldl'" $ do 78 | prop "text foldl' === List.foldl'" $ \ xs f x -> 79 | (T.foldl' (applyFun2 f :: Char -> Char -> Char) x (T.pack xs)) === 80 | (List.foldl' (applyFun2 f) x $ xs) 81 | 82 | describe "text foldr' == List.foldr'" $ do 83 | prop "text foldr' === List.foldr" $ \ xs f x -> 84 | (T.foldr' (applyFun2 f :: Char -> Char -> Char) x (T.pack xs)) === 85 | (List.foldr (applyFun2 f) x $ xs) 86 | 87 | describe "text concat == List.concat" $ do 88 | prop "text concat === List.concat" $ \ xss -> 89 | (T.concat $ List.map (T.pack . getUnicodeString) xss) === 90 | (T.pack . List.concat $ List.map getUnicodeString xss) 91 | 92 | describe "text concatMap == List.concatMap" $ do 93 | prop "text concatMap === List.concatMap" $ \ xs (Fun _ f) -> 94 | (T.concatMap (T.pack . f) . T.pack . getUnicodeString) xs === 95 | (T.pack . List.concatMap f $ getUnicodeString xs) 96 | 97 | describe "text all == List.all" $ do 98 | prop "text all === List.all" $ \ xs (Fun _ f) -> 99 | (T.all f $ T.pack xs) === (List.all f $ xs) 100 | 101 | describe "text any == List.any" $ do 102 | prop "text any === List.any" $ \ xs (Fun _ f) -> 103 | (T.any f $ T.pack xs) === (List.any f $ xs) 104 | 105 | describe "text count x == List.length . List.filter (==x)" $ do 106 | prop "text count === List.length . List.filter (==x)" $ \ xs x -> 107 | (T.count x $ T.pack xs) === (List.length . List.filter (==x) $ xs) 108 | 109 | describe "text replicate == List.replicate" $ do 110 | prop "text replicate = List.replicate" $ \ n x -> 111 | (T.replicate n x) == (T.pack (List.replicate n $ x)) 112 | 113 | -------------------------------------------------------------------------------- /std-io/test/Std/IO/ResourceSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Std.IO.ResourceSpec where 5 | 6 | import Control.Concurrent 7 | import Control.Exception 8 | import Control.Monad 9 | import Std.Data.PrimIORef 10 | import Data.Typeable 11 | import Std.IO.Resource as R 12 | import Test.Hspec 13 | import Test.HUnit 14 | 15 | data WorkerException = WorkerException deriving (Typeable, Show) 16 | 17 | instance Exception WorkerException 18 | 19 | spec :: Spec 20 | spec = describe "resource tests" $ do 21 | it "resource pool" $ do 22 | resCounter <- newCounter 0 23 | workerCounter <- newCounter 0 24 | let res = initResource (atomicAddCounter_ resCounter 1) 25 | (\ _ -> atomicSubCounter_ resCounter 1) 26 | resPool = initPool res 100 1 27 | R.withResource resPool $ \ pool -> do 28 | let res = initInPool pool 29 | replicateM_ 300 . forkIO. R.withResource res $ \ _ -> do 30 | atomicAddCounter_ workerCounter 1 31 | r <- readPrimIORef resCounter 32 | threadDelay 1000000 33 | assertEqual "pool should limit max usage" True (r <= 100) 34 | 35 | threadDelay 4000000 -- first 100 worker quickly get resources 36 | -- then hold for 1s, rest 100 worker have to wait, and so on 37 | -- so here we wait for 4s to make sure every worker got a resource 38 | -- we used to use replicateConcurrently_ from async, but it's 39 | -- not really neccessary 40 | 41 | w <- readPrimIORef workerCounter 42 | assertEqual "worker should be able to get resource" 300 w 43 | 44 | r <- readPrimIORef resCounter 45 | assertEqual "pool should keep returned resources alive" 100 r 46 | 47 | s <- statPool pool 48 | assertEqual "pool should be scanning returned resources" PoolScanning s 49 | 50 | threadDelay 1200000 -- another 1.2s 51 | 52 | r <- readPrimIORef resCounter 53 | assertEqual "pool should reap unused resources" 0 r 54 | 55 | threadDelay 1200000 -- another 1.2s 56 | 57 | s <- statPool pool 58 | assertEqual "pool should stop scanning returned resources" PoolEmpty s 59 | 60 | -- Let's test again 61 | 62 | writePrimIORef workerCounter 0 63 | 64 | replicateM_ 300 . forkIO. R.withResource res $ \ _ -> do 65 | atomicAddCounter_ workerCounter 1 66 | r <- readPrimIORef resCounter 67 | threadDelay 1000000 68 | assertEqual "pool should limit max usage" True (r <= 100) 69 | 70 | threadDelay 4000000 71 | 72 | w <- readPrimIORef workerCounter 73 | assertEqual "worker should be able to get resource" 300 w 74 | 75 | r <- readPrimIORef resCounter 76 | assertEqual "pool should keep returned resources alive" 100 r 77 | 78 | s <- statPool pool 79 | assertEqual "pool should be scanning returned resources" PoolScanning s 80 | 81 | threadDelay 1200000 -- another 1.2s 82 | 83 | r <- readPrimIORef resCounter 84 | assertEqual "pool should reap unused resources" 0 r 85 | 86 | threadDelay 1200000 -- another 1.2s 87 | 88 | s <- statPool pool 89 | assertEqual "pool should stop scanning returned resources" PoolEmpty s 90 | 91 | it "resource pool under exceptions" $ do 92 | resCounter <- newCounter 0 93 | let res = initResource (atomicAddCounter' resCounter 1) 94 | (\ _ -> atomicSubCounter_ resCounter 1) 95 | resPool = initPool res 100 1 96 | R.withResource resPool $ \ pool -> do 97 | let res = initInPool pool 98 | handle (\ (e :: WorkerException) -> return ()) . 99 | replicateM_ 300 . forkIO. R.withResource res $ \ i -> do 100 | r <- readPrimIORef resCounter 101 | threadDelay 1000000 102 | when (even i) (throwIO WorkerException) 103 | assertEqual "pool should limit max usage" True (r <= 100) 104 | 105 | threadDelay 4000000 106 | 107 | r <- readPrimIORef resCounter 108 | assertEqual "pool should keep returned resources alive" 100 r 109 | 110 | s <- statPool pool 111 | assertEqual "pool should be scanning returned resources" PoolScanning s 112 | 113 | threadDelay 1200000 -- another 1.2s 114 | 115 | r <- readPrimIORef resCounter 116 | assertEqual "pool should reap unused resources" 0 r 117 | 118 | threadDelay 1200000 -- another 1.2s 119 | 120 | s <- statPool pool 121 | assertEqual "pool should stop scanning returned resources" PoolEmpty s 122 | -------------------------------------------------------------------------------- /std-data/test/Std/Data/Parser/BaseSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Std.Data.Parser.BaseSpec where 5 | 6 | import qualified Data.List as L 7 | import Data.Word 8 | import Data.Int 9 | import GHC.Float 10 | import Text.Printf (printf) 11 | import Data.Word8 (toLower, toUpper) 12 | import qualified Std.Data.Parser.Base as P 13 | import qualified Std.Data.Text as T 14 | import qualified Std.Data.Vector.Base as V 15 | import Test.QuickCheck 16 | import Test.QuickCheck.Function 17 | import Test.QuickCheck.Property 18 | import Test.Hspec 19 | import Test.Hspec.QuickCheck 20 | 21 | 22 | parse' :: P.Parser a -> [Word8] -> Maybe a 23 | parse' p str = case P.parse_ p (V.pack str) of 24 | Left msg -> Nothing 25 | Right a -> Just a 26 | 27 | parse'' :: P.Parser a -> [Word8] -> Maybe (V.Bytes, a) 28 | parse'' p str = case P.parse p (V.pack str) of 29 | (rest, Right a) -> Just (rest, a) 30 | _ -> Nothing 31 | 32 | spec :: Spec 33 | spec = describe "parsers" . modifyMaxSuccess (*10) . modifyMaxSize (*10) $ do 34 | prop "satisfy" $ \ w s -> 35 | parse' (P.satisfy (<=w)) (w:s) === Just w 36 | 37 | prop "satisfyWith" $ \ w s (Fun _ f) -> 38 | parse' (P.satisfyWith f (== f w)) (w:s) === Just (f w :: Int) 39 | 40 | prop "word8" $ \ w w' s -> 41 | parse' (P.word8 w) (w':s) === 42 | (if w == w' then Just () else Nothing) 43 | 44 | prop "skipWhile" $ \ s (Fun _ f) -> 45 | parse'' (P.skipWhile f) s === Just (V.pack (L.dropWhile f s), ()) 46 | 47 | prop "takeWhile" $ \ s (Fun _ f) -> 48 | parse'' (P.takeWhile f) s === Just (V.pack (L.dropWhile f s), V.pack (L.takeWhile f s)) 49 | 50 | prop "takeTill" $ \ s (Fun _ f) -> 51 | let (s1, s2) = L.break f s 52 | in parse'' (P.takeTill f) s === Just (V.pack s2, V.pack s1) 53 | 54 | prop "takeWhile1" $ \ s (Fun _ f) -> 55 | parse'' (P.takeWhile1 f) s === 56 | case s of 57 | (w:_) | f w -> Just (V.pack (L.dropWhile f s), V.pack (L.takeWhile f s)) 58 | _ -> Nothing 59 | 60 | prop "take" $ \ s n -> 61 | parse'' (P.take n) s === 62 | if L.length s >= n 63 | then Just (V.pack (L.drop n s), V.pack (L.take n s)) 64 | else Nothing 65 | 66 | prop "skip" $ \ s n -> 67 | parse'' (P.skip n) s === 68 | if L.length s >= n 69 | then Just (V.pack (L.drop n s), ()) 70 | else Nothing 71 | 72 | prop "skipWord8" $ \ s -> 73 | parse' (P.skipWord8 *> P.takeWhile (const True)) s === 74 | case s of [] -> Nothing 75 | (w:s') -> Just (V.pack s') 76 | 77 | prop "peek" $ \ s -> 78 | parse' ((,) <$> P.peek <*> P.takeWhile (const True)) s === 79 | case s of [] -> Nothing 80 | (w:_) -> Just (w, V.pack s) 81 | 82 | prop "peekMaybe" $ \ s -> 83 | parse' ((,) <$> P.peekMaybe <*> P.takeWhile (const True)) s === 84 | case s of [] -> Just (Nothing, V.pack s) 85 | (w:_) -> Just (Just w, V.pack s) 86 | 87 | prop "bytes" $ \ s t -> 88 | parse' (P.bytes . V.pack $ t) s === 89 | if L.take (L.length t) s == t then Just () else Nothing 90 | 91 | prop "bytes" $ \ s t -> 92 | parse'' (P.bytes . V.pack $ t) (t ++ s) === Just (V.pack s, ()) 93 | 94 | prop "bytes" $ \ s t u -> 95 | parse'' (P.bytes (V.pack s) >> P.bytes (V.pack t)) (s ++ t ++ u) === Just (V.pack u, ()) 96 | 97 | prop "bytesCI" $ \ s t -> 98 | parse'' (P.bytesCI . V.pack $ t) (t ++ s) === Just (V.pack s, ()) 99 | 100 | prop "bytesCI" $ \ s t -> 101 | parse'' (P.bytesCI . V.pack $ t) (L.map toLower t ++ s) === Just (V.pack s, ()) 102 | 103 | prop "atEnd" $ \ s -> 104 | parse' P.atEnd s === 105 | case s of [] -> Just True 106 | _ -> Just False 107 | 108 | prop "scan" $ \ s l -> 109 | let go l _ | l <= 0 = Nothing 110 | | otherwise = Just (l-1) 111 | in (fst <$> parse' (P.scan l go) s) === Just (V.pack $ L.take l s) 112 | 113 | prop "endOfLine" $ \ s -> 114 | let r = fromIntegral (fromEnum '\r') 115 | n = fromIntegral (fromEnum '\n') 116 | in parse'' (P.skipWhile (\w -> w `L.notElem` [r, n]) >> P.endOfLine) s === 117 | case break (\w -> w `L.elem` [r, n]) s of 118 | (_, bs) -> case bs of 119 | (b:bs') | b == n -> Just (V.pack bs', ()) 120 | (b:c:bs') | b == r && c == n -> Just (V.pack bs', ()) 121 | _ -> Nothing 122 | 123 | -------------------------------------------------------------------------------- /std-data/Std/Data/Text/Search.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MagicHash #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE UnboxedTuples #-} 6 | 7 | 8 | {-| 9 | Module : Std.Data.Text.Search 10 | Description : Searching text 11 | Copyright : (c) Dong Han, 2017-2018 12 | License : BSD 13 | Maintainer : winterland1989@gmail.com 14 | Stability : experimental 15 | Portability : non-portable 16 | 17 | -} 18 | 19 | module Std.Data.Text.Search ( 20 | -- * element-wise search 21 | elem, notElem 22 | -- * Searching by equality 23 | , findIndices 24 | , find, findR 25 | , findIndex 26 | , findIndexR 27 | , filter, partition 28 | ) where 29 | 30 | 31 | import Control.Monad.ST 32 | import Data.Word 33 | import Prelude hiding (elem, notElem, filter) 34 | import Std.Data.Array 35 | import Std.Data.Text.Base 36 | import Std.Data.Text.UTF8Codec 37 | import qualified Std.Data.Vector.Base as V 38 | 39 | findIndices :: (Char -> Bool) -> Text -> [Int] 40 | {-# INLINE findIndices #-} 41 | findIndices f (Text (V.PrimVector arr s l)) = go 0 s 42 | where 43 | !end = s + l 44 | go !i !p | p >= end = [] 45 | | f x = i : go (i+1) (p+off) 46 | | otherwise = go (i+1) (p+off) 47 | where (# x, off #) = decodeChar arr p 48 | 49 | -- | /O(n)/ find the first char matching the predicate in a text 50 | -- from left to right, if there isn't one, return the index point to the end of the byte slice. 51 | find :: (Char -> Bool) 52 | -> Text 53 | -> (Int, Int, Maybe Char) -- ^ (char index, byte index in slice, matching char) 54 | {-# INLINE find #-} 55 | find f (Text (V.PrimVector arr s l)) = go 0 s 56 | where 57 | !end = s + l 58 | go !i !j | j >= end = (i, j, Nothing) 59 | | otherwise = 60 | let (# x, off #) = decodeChar arr j 61 | in if f x 62 | then (i, j, Just x) 63 | else go (i+1) (j+off) 64 | 65 | -- | /O(n)/ find the first char matching the predicate in a text 66 | -- from right to left, if there isn't one, return the index point to the start of the byte slice. 67 | -- 68 | findR :: (Char -> Bool) 69 | -> Text 70 | -> (Int, Int, Maybe Char) -- ^ (char index(counting backwards), byte index in slice, matching char) 71 | {-# INLINE findR #-} 72 | findR f (Text (V.PrimVector arr s l)) = go 0 (s+l-1) 73 | where 74 | go !i !j | j < s = (i, j, Nothing) 75 | | otherwise = 76 | let (# x, off #) = decodeCharReverse arr j 77 | in if f x 78 | then (i, j, Just x) 79 | else go (i+1) (j-off) 80 | 81 | -------------------------------------------------------------------------------- 82 | 83 | -- | /O(n)/ find the index of the byte slice. 84 | findIndex :: (Char -> Bool) -> Text -> Int 85 | {-# INLINE findIndex #-} 86 | findIndex f t = case find f t of (_, i, _) -> i 87 | 88 | -- | /O(n)/ find the index of the byte slice in reverse order. 89 | findIndexR :: (Char -> Bool) -> Text -> Int 90 | {-# INLINE findIndexR #-} 91 | findIndexR f t = case findR f t of (_, i, _) -> i 92 | 93 | -- | /O(n)/ 'filter', applied to a predicate and a text, 94 | -- returns a text containing those chars that satisfy the 95 | -- predicate. 96 | filter :: (Char -> Bool) -> Text -> Text 97 | {-# INLINE filter #-} 98 | filter f (Text (V.PrimVector arr s l)) = Text (V.createN l (go s 0)) 99 | where 100 | !end = s + l 101 | go :: Int -> Int -> MutablePrimArray s Word8 -> ST s Int 102 | go !i !j marr 103 | | i >= end = return j 104 | | otherwise = 105 | let (# x, off #) = decodeChar arr i 106 | in if f x 107 | then do 108 | copyChar off marr j arr i 109 | go (i+off) (j+off) marr 110 | else go (i+off) j marr 111 | 112 | -- | /O(n)/ The 'partition' function takes a predicate, a text, returns 113 | -- a pair of text with codepoints which do and do not satisfy the 114 | -- predicate, respectively; i.e., 115 | -- 116 | -- > partition p txt == (filter p txt, filter (not . p) txt) 117 | partition :: (Char -> Bool) -> Text -> (Text, Text) 118 | {-# INLINE partition #-} 119 | partition f (Text (V.PrimVector arr s l)) 120 | | l == 0 = (empty, empty) 121 | | otherwise = let !(bs1, bs2) = V.createN2 l l (go 0 0 s) in (Text bs1, Text bs2) 122 | where 123 | !end = s + l 124 | go :: Int -> Int -> Int -> MutablePrimArray s Word8 -> MutablePrimArray s Word8 -> ST s (Int, Int) 125 | go !i !j !p !mba0 !mba1 126 | | p >= end = return (i, j) 127 | | otherwise = 128 | let (# x, off #) = decodeChar arr p 129 | in if f x 130 | then copyChar off mba0 i arr p >> go (i+off) j (p+off) mba0 mba1 131 | else copyChar off mba1 j arr p >> go i (j+off) (p+off) mba0 mba1 132 | 133 | -------------------------------------------------------------------------------- 134 | -- Searching by equality 135 | 136 | -- | /O(n)/ 'elem' test if given char is in given text. 137 | elem :: Char -> Text -> Bool 138 | {-# INLINE elem #-} 139 | elem x t = case find (x==) t of (_,_,Nothing) -> False 140 | _ -> True 141 | 142 | -- | /O(n)/ @not . elem@ 143 | notElem :: Char -> Text -> Bool 144 | {-# INLINE notElem #-} 145 | notElem x = not . elem x 146 | -------------------------------------------------------------------------------- /std-data/test/Std/Data/Parser/NumericSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Std.Data.Parser.NumericSpec where 5 | 6 | import qualified Data.List as L 7 | import Data.Word 8 | import Data.Int 9 | import GHC.Float 10 | import Text.Printf (printf) 11 | import Data.Word8 (toLower, toUpper) 12 | import qualified Std.Data.Parser.Numeric as P 13 | import qualified Std.Data.Parser.Base as P 14 | import qualified Std.Data.Builder.Numeric as B 15 | import qualified Std.Data.Builder.Base as B 16 | import qualified Std.Data.Text as T 17 | import qualified Std.Data.Vector.Base as V 18 | import qualified Data.Scientific as Sci 19 | import Test.QuickCheck 20 | import Test.QuickCheck.Function 21 | import Test.QuickCheck.Property 22 | import Test.Hspec 23 | import Test.Hspec.QuickCheck 24 | 25 | spec :: Spec 26 | spec = do 27 | describe "numeric parsers roundtrip" . modifyMaxSuccess (*10) . modifyMaxSize (*10) $ do 28 | prop "positive hex roundtrip" $ \ i -> 29 | P.parse_ P.hex (B.buildBytes (B.hex i)) === Right (i :: Int) 30 | prop "positive hex roundtrip" $ \ i -> 31 | P.parse_ P.hex (B.buildBytes (B.hex i)) === Right (i :: Int64) 32 | prop "positive hex roundtrip" $ \ i -> 33 | P.parse_ P.hex (B.buildBytes (B.hex i)) === Right (i :: Int32) 34 | prop "positive hex roundtrip" $ \ i -> 35 | P.parse_ P.hex (B.buildBytes (B.hex i)) === Right (i :: Int16) 36 | prop "positive hex roundtrip" $ \ i -> 37 | P.parse_ P.hex (B.buildBytes (B.hex i)) === Right (i :: Int8) 38 | prop "positive hex roundtrip" $ \ i -> 39 | P.parse_ P.hex (B.buildBytes (B.hex i)) === Right (i :: Word) 40 | prop "positive hex roundtrip" $ \ i -> 41 | P.parse_ P.hex (B.buildBytes (B.hex i)) === Right (i :: Word64) 42 | prop "positive hex roundtrip" $ \ i -> 43 | P.parse_ P.hex (B.buildBytes (B.hex i)) === Right (i :: Word32) 44 | prop "positive hex roundtrip" $ \ i -> 45 | P.parse_ P.hex (B.buildBytes (B.hex i)) === Right (i :: Word16) 46 | prop "positive hex roundtrip" $ \ i -> 47 | P.parse_ P.hex (B.buildBytes (B.hex i)) === Right (i :: Word8) 48 | 49 | 50 | prop "positive int roundtrip" $ \ (Positive i) -> 51 | P.parse_ P.uint (B.buildBytes (B.int i)) === Right (i :: Int) 52 | prop "positive int roundtrip" $ \ (Positive i) -> 53 | P.parse_ P.uint (B.buildBytes (B.int i)) === Right (i :: Int64) 54 | prop "positive int roundtrip" $ \ (Positive i) -> 55 | P.parse_ P.uint (B.buildBytes (B.int i)) === Right (i :: Int32) 56 | prop "positive int roundtrip" $ \ (Positive i) -> 57 | P.parse_ P.uint (B.buildBytes (B.int i)) === Right (i :: Int16) 58 | prop "positive int roundtrip" $ \ (Positive i) -> 59 | P.parse_ P.uint (B.buildBytes (B.int i)) === Right (i :: Int8) 60 | prop "positive int roundtrip" $ \ (Positive i) -> 61 | P.parse_ P.uint (B.buildBytes (B.int i)) === Right (i :: Word) 62 | prop "positive int roundtrip" $ \ (Positive i) -> 63 | P.parse_ P.uint (B.buildBytes (B.int i)) === Right (i :: Word64) 64 | prop "positive int roundtrip" $ \ (Positive i) -> 65 | P.parse_ P.uint (B.buildBytes (B.int i)) === Right (i :: Word32) 66 | prop "positive int roundtrip" $ \ (Positive i) -> 67 | P.parse_ P.uint (B.buildBytes (B.int i)) === Right (i :: Word16) 68 | prop "positive int roundtrip" $ \ (Positive i) -> 69 | P.parse_ P.uint (B.buildBytes (B.int i)) === Right (i :: Word8) 70 | 71 | 72 | prop "positive int roundtrip" $ \ i -> 73 | P.parse_ P.int (B.buildBytes (B.int i)) === Right (i :: Int) 74 | prop "positive int roundtrip" $ \ i -> 75 | P.parse_ P.int (B.buildBytes (B.int i)) === Right (i :: Int64) 76 | prop "positive int roundtrip" $ \ i -> 77 | P.parse_ P.int (B.buildBytes (B.int i)) === Right (i :: Int32) 78 | prop "positive int roundtrip" $ \ i -> 79 | P.parse_ P.int (B.buildBytes (B.int i)) === Right (i :: Int16) 80 | prop "positive int roundtrip" $ \ i -> 81 | P.parse_ P.int (B.buildBytes (B.int i)) === Right (i :: Int8) 82 | prop "positive int roundtrip" $ \ i -> 83 | P.parse_ P.int (B.buildBytes (B.int i)) === Right (i :: Word) 84 | prop "positive int roundtrip" $ \ i -> 85 | P.parse_ P.int (B.buildBytes (B.int i)) === Right (i :: Word64) 86 | prop "positive int roundtrip" $ \ i -> 87 | P.parse_ P.int (B.buildBytes (B.int i)) === Right (i :: Word32) 88 | prop "positive int roundtrip" $ \ i -> 89 | P.parse_ P.int (B.buildBytes (B.int i)) === Right (i :: Word16) 90 | prop "positive int roundtrip" $ \ i -> 91 | P.parse_ P.int (B.buildBytes (B.int i)) === Right (i :: Word8) 92 | 93 | prop "float roundtrip" $ \ i -> 94 | P.parse_ P.float (B.buildBytes (B.float i)) === Right (i :: Float) 95 | prop "double roundtrip" $ \ i -> 96 | P.parse_ P.double (B.buildBytes (B.double i)) === Right (i :: Double) 97 | 98 | describe "floatToScientific, doubleToScientific === fromFloatDigits" $ do 99 | prop "floatToScientific == fromFloatDigits" $ \ i -> 100 | P.floatToScientific i === Sci.fromFloatDigits i 101 | prop "floatToScientific === fromFloatDigits" $ \ i -> 102 | P.doubleToScientific i === Sci.fromFloatDigits i 103 | -------------------------------------------------------------------------------- /std-io/test/Std/IO/FileSystemSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Std.IO.FileSystemSpec where 4 | 5 | import Control.Concurrent.MVar (readMVar) 6 | import Control.Monad 7 | import Data.Bits 8 | import Std.Data.Vector as V 9 | import Std.Data.Vector.Base as V 10 | import Data.List as List 11 | import Foreign.Marshal.Array 12 | import Foreign.Ptr 13 | import Std.IO.Buffered 14 | import Std.IO.Exception 15 | import Std.IO.FileSystem 16 | import Std.IO.Resource 17 | import Std.IO.UV.Manager 18 | import Test.Hspec 19 | import Test.HUnit 20 | 21 | spec :: Spec 22 | spec = describe "filesystem operations" $ do 23 | 24 | let content = "Hello world!" 25 | content2 = V.cycleN 1024 "quick fox jumps over the lazy dog, 世界你好!\n" 26 | size = V.length content 27 | size2 = V.length content2 28 | 29 | 30 | it "create a temp dir" $ do 31 | tempdir <- mkdtemp "stdio-filesystem-unit" 32 | dirs <- scandir "./" 33 | rmdir tempdir 34 | List.lookup tempdir dirs @?= Just DirEntDir 35 | 36 | 37 | let flags = O_RDWR .|. O_CREAT 38 | mode = DEFAULT_MODE 39 | filename = "test-file" 40 | 41 | it "Opens and writes a file" $ do 42 | withResource (initUVFile filename flags mode) $ \ file -> do 43 | o <- newBufferedOutput file 4096 44 | writeBuffer o content 45 | flushBuffer o 46 | 47 | withResource (initUVFile filename flags mode) $ \ file -> do 48 | i <- newBufferedInput file 4096 49 | written <- readExactly size i 50 | written @=? content 51 | 52 | fr <- newUVFileReader file 0 53 | i <- newBufferedInput fr 4096 54 | written <- readExactly size i 55 | written @=? content 56 | 57 | unlink filename 58 | 59 | it "Opens and writes a file II" $ do 60 | withResource (initUVFile filename flags mode) $ \ file -> do 61 | o <- newBufferedOutput file 4096 62 | writeBuffer o content2 63 | flushBuffer o 64 | 65 | withResource (initUVFile filename flags mode) $ \ file -> do 66 | i <- newBufferedInput file 4096 67 | written <- readExactly size2 i 68 | written @=? content2 69 | 70 | withResource (initUVFile filename flags mode) $ \ file -> do 71 | i <- newBufferedInput file 4096 72 | firstLine <- readLine i 73 | firstLine @=? fst (V.break (== V.c2w '\n') content2) 74 | 75 | fr <- newUVFileReader file 0 76 | i <- newBufferedInput fr 4096 77 | replicateM_ 1024 $ do 78 | firstLine <- readLine i 79 | firstLine @=? fst (V.break (== V.c2w '\n') content2) 80 | unlink filename 81 | 82 | 83 | it "create and remove dir" $ do 84 | tempdir <- mkdtemp "stdio-filesystem-unit" 85 | let dirname = tempdir <> "/test-dir" 86 | mkdir dirname mode 87 | dirs <- scandir tempdir 88 | print dirs 89 | rmdir dirname 90 | rmdir tempdir 91 | List.lookup "test-dir" dirs @?= Just DirEntDir 92 | 93 | let linkname = "test-link" 94 | symlinkname = "test-symlink" 95 | symlinkname2 = "test-symlink2" 96 | 97 | it "link stat should be equal to target file" $ do 98 | 99 | withResource (initUVFile filename flags mode) $ \ file -> return () 100 | 101 | s0 <- stat filename 102 | 103 | link filename linkname 104 | symlink "test-link" symlinkname SYMLINK_DEFAULT 105 | 106 | absfp <- realpath filename 107 | symlink absfp symlinkname2 SYMLINK_DEFAULT -- the second way to create a proper symlink 108 | 109 | s1 <- stat linkname 110 | s2 <- stat symlinkname 111 | s2' <- stat symlinkname2 112 | 113 | s0 @?= s1 {stNlink = 1} -- update hard link number 114 | s0 @?= s2 {stNlink = 1} 115 | s0 @?= s2' {stNlink = 1} 116 | 117 | withResource (initUVFile filename flags mode) $ \ file -> do 118 | s4 <- fstat file 119 | s0 @?= s4 {stNlink = 1} 120 | 121 | unlink filename 122 | unlink linkname 123 | unlink symlinkname 124 | unlink symlinkname2 125 | 126 | it "utime result in stat change" $ do 127 | withResource (initUVFile filename flags mode) $ \ file -> return () 128 | utime filename 1000.2000 3000.4000 129 | s <- stat filename 130 | print s 131 | uvtSecond (stAtim s) @?= 1000 132 | uvtNanoSecond (stAtim s) @?= 200000000 133 | uvtSecond (stMtim s) @?= 3000 134 | uvtNanoSecond (stMtim s) @?= 400000000 135 | unlink filename 136 | 137 | it "futime result in fstat change" $ do 138 | withResource (initUVFile filename flags mode) $ \ file -> do 139 | futime file 5000.6000 7000.8000 140 | s <- fstat file 141 | print s 142 | uvtSecond (stAtim s) @?= 5000 143 | uvtNanoSecond (stAtim s) @?= 600000000 144 | uvtSecond (stMtim s) @?= 7000 145 | uvtNanoSecond (stMtim s) @?= 800000000 146 | unlink filename 147 | 148 | -------------------------------------------------------------------------------- /std-io/test/Std/IO/FileSystemTSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Std.IO.FileSystemTSpec where 4 | 5 | import Control.Concurrent.MVar (readMVar) 6 | import Control.Monad 7 | import Data.Bits 8 | import Std.Data.Vector as V 9 | import Std.Data.Vector.Base as V 10 | import Data.List as List 11 | import Foreign.Marshal.Array 12 | import Foreign.Ptr 13 | import Std.IO.Buffered 14 | import Std.IO.Exception 15 | import Std.IO.FileSystemT 16 | import Std.IO.Resource 17 | import Std.IO.UV.Manager 18 | import Test.Hspec 19 | import Test.HUnit 20 | 21 | spec :: Spec 22 | spec = describe "filesystem (threadpool version) operations" $ do 23 | 24 | let content = "Hello world!" 25 | content2 = V.cycleN 1024 "quick fox jumps over the lazy dog, 世界你好!\n" 26 | size = V.length content 27 | size2 = V.length content2 28 | 29 | it "create a temp dir" $ do 30 | tempdir <- mkdtemp "stdio-filesystem-unit" 31 | dirs <- scandir "./" 32 | rmdir tempdir 33 | List.lookup tempdir dirs @?= Just DirEntDir 34 | 35 | 36 | let flags = O_RDWR .|. O_CREAT 37 | mode = DEFAULT_MODE 38 | filename = "test-file" 39 | 40 | it "Opens and writes a file" $ do 41 | withResource (initUVFile filename flags mode) $ \ file -> do 42 | o <- newBufferedOutput file 4096 43 | writeBuffer o content 44 | flushBuffer o 45 | 46 | withResource (initUVFile filename flags mode) $ \ file -> do 47 | i <- newBufferedInput file 4096 48 | written <- readExactly size i 49 | written @=? content 50 | 51 | fr <- newUVFileReader file 0 52 | i <- newBufferedInput fr 4096 53 | written <- readExactly size i 54 | written @=? content 55 | 56 | unlink filename 57 | 58 | it "Opens and writes a file II" $ do 59 | withResource (initUVFile filename flags mode) $ \ file -> do 60 | o <- newBufferedOutput file 4096 61 | writeBuffer o content2 62 | flushBuffer o 63 | 64 | withResource (initUVFile filename flags mode) $ \ file -> do 65 | i <- newBufferedInput file 4096 66 | written <- readExactly size2 i 67 | written @=? content2 68 | 69 | withResource (initUVFile filename flags mode) $ \ file -> do 70 | i <- newBufferedInput file 4096 71 | firstLine <- readLine i 72 | firstLine @=? fst (V.break (== V.c2w '\n') content2) 73 | 74 | fr <- newUVFileReader file 0 75 | i <- newBufferedInput fr 4096 76 | replicateM_ 1024 $ do 77 | firstLine <- readLine i 78 | firstLine @=? fst (V.break (== V.c2w '\n') content2) 79 | unlink filename 80 | 81 | 82 | it "create and remove dir" $ do 83 | tempdir <- mkdtemp "stdio-filesystem-unit" 84 | let dirname = tempdir <> "/test-dir" 85 | mkdir dirname mode 86 | dirs <- scandir tempdir 87 | print dirs 88 | rmdir dirname 89 | rmdir tempdir 90 | List.lookup "test-dir" dirs @?= Just DirEntDir 91 | 92 | let linkname = "test-link" 93 | symlinkname = "test-symlink" 94 | symlinkname2 = "test-symlink2" 95 | 96 | it "link stat should be equal to target file" $ do 97 | 98 | withResource (initUVFile filename flags mode) $ \ file -> return () 99 | 100 | s0 <- stat filename 101 | 102 | link filename linkname 103 | symlink "test-link" symlinkname SYMLINK_DEFAULT 104 | 105 | absfp <- realpath filename 106 | symlink absfp symlinkname2 SYMLINK_DEFAULT -- the second way to create a proper symlink 107 | 108 | s1 <- stat linkname 109 | s2 <- stat symlinkname 110 | s2' <- stat symlinkname2 111 | 112 | s0 @?= s1 {stNlink = 1} -- update hard link number 113 | s0 @?= s2 {stNlink = 1} 114 | s0 @?= s2' {stNlink = 1} 115 | 116 | withResource (initUVFile filename flags mode) $ \ file -> do 117 | s4 <- fstat file 118 | s0 @?= s4 {stNlink = 1} 119 | 120 | unlink filename 121 | unlink linkname 122 | unlink symlinkname 123 | unlink symlinkname2 124 | 125 | it "utime result in stat change" $ do 126 | withResource (initUVFile filename flags mode) $ \ file -> return () 127 | utime filename 1000.2000 3000.4000 128 | s <- stat filename 129 | print s 130 | uvtSecond (stAtim s) @?= 1000 131 | uvtNanoSecond (stAtim s) @?= 200000000 132 | uvtSecond (stMtim s) @?= 3000 133 | uvtNanoSecond (stMtim s) @?= 400000000 134 | unlink filename 135 | 136 | it "futime result in fstat change" $ do 137 | withResource (initUVFile filename flags mode) $ \ file -> do 138 | futime file 5000.6000 7000.8000 139 | s <- fstat file 140 | print s 141 | uvtSecond (stAtim s) @?= 5000 142 | uvtNanoSecond (stAtim s) @?= 600000000 143 | uvtSecond (stMtim s) @?= 7000 144 | uvtNanoSecond (stMtim s) @?= 800000000 145 | unlink filename 146 | 147 | -------------------------------------------------------------------------------- /std-io/cbits/hs_uv_udp.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2017-2019 Dong Han 3 | * 4 | * All rights reserved. 5 | * 6 | * Redistribution and use in source and binary forms, with or without 7 | * modification, are permitted provided that the following conditions 8 | * are met: 9 | * 1. Redistributions of source code must retain the above copyright 10 | * notice, this list of conditions and the following disclaimer. 11 | * 2. Redistributions in binary form must reproduce the above copyright 12 | * notice, this list of conditions and the following disclaimer in the 13 | * documentation and/or other materials provided with the distribution. 14 | * 3. Neither the names of the authors or the names of any contributors 15 | * may be used to endorse or promote products derived from this software 16 | * without specific prior written permission. 17 | * 18 | * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 19 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 22 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 24 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 25 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 26 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 27 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 28 | * SUCH DAMAGE. 29 | */ 30 | 31 | #include 32 | 33 | //////////////////////////////////////////////////////////////////////////////// 34 | // 35 | // udp 36 | 37 | // We do batch read per uv_run, the buffer index keep decreasing until hit zero 38 | // then we call uv_udp_recv_stop to stop receiving. 39 | void hs_udp_alloc_cb(uv_handle_t* handle, size_t suggested_size, uv_buf_t* buf){ 40 | HsInt slot = (HsInt)handle->data; 41 | hs_loop_data* loop_data = handle->loop->data; 42 | // fetch buffer_table from buffer_table table 43 | // the first 12 + 128 bytes is reserved for sockaddr and flag 44 | char** buffer_array = (char**)loop_data->buffer_table[slot]; 45 | (loop_data->buffer_size_table[slot])--; 46 | ssize_t buffer_index = loop_data->buffer_size_table[slot]; 47 | if (buffer_index < 0) { 48 | uv_udp_recv_stop((uv_udp_t*)handle); 49 | buf->base = NULL; 50 | buf->len = 0; 51 | } else { 52 | buf->base = (char*)buffer_array[buffer_index] + 140; 53 | buf->len = *((int32_t*)buffer_array[buffer_index]); 54 | } 55 | } 56 | 57 | void hs_udp_recv_cb (uv_udp_t* udp, ssize_t nread, const uv_buf_t* _buf 58 | , const struct sockaddr* addr, unsigned flags){ 59 | if (nread ==0 && addr == NULL) return; 60 | HsInt slot = (HsInt)udp->data; 61 | hs_loop_data* loop_data = udp->loop->data; 62 | 63 | char* buf = (char*)(_buf->base)-140; 64 | struct sockaddr* addr_buf = (struct sockaddr*)(buf+12); 65 | // result 66 | *(int32_t*)buf = (int32_t)nread; 67 | // flag 68 | *(int32_t*)(buf+4) = (int32_t)flags; 69 | 70 | if (addr == NULL) { 71 | // set sockaddr flag 72 | *(int32_t*)(buf+8) = 0; 73 | } else { 74 | // set sockaddr flag 75 | *(int32_t*)(buf+8) = 1; 76 | // copy sockaddr 77 | if (addr->sa_family == AF_INET){ 78 | memcpy(addr_buf, addr, sizeof(struct sockaddr_in)); 79 | } else if (addr->sa_family == AF_INET6){ 80 | memcpy(addr_buf, addr, sizeof(struct sockaddr_in6)); 81 | } else { 82 | memcpy(addr_buf, addr, sizeof(struct sockaddr)); 83 | } 84 | } 85 | if (nread != 0) { 86 | loop_data->event_queue[loop_data->event_counter] = slot; // push the slot to event queue 87 | loop_data->event_counter += 1; 88 | uv_udp_recv_stop(udp); 89 | } 90 | } 91 | 92 | int hs_uv_udp_recv_start(uv_udp_t* handle){ 93 | return uv_udp_recv_start(handle, hs_udp_alloc_cb, hs_udp_recv_cb); 94 | } 95 | 96 | void hs_uv_udp_send_cb(uv_udp_send_t* req, int status){ 97 | HsInt slot = (HsInt)req->data; 98 | uv_loop_t* loop = req->handle->loop; 99 | hs_loop_data* loop_data = loop->data; 100 | loop_data->buffer_size_table[slot] = (HsInt)status; // 0 in case of success, < 0 otherwise. 101 | loop_data->event_queue[loop_data->event_counter] = slot; // push the slot to event queue 102 | loop_data->event_counter += 1; 103 | free_slot(loop_data, slot); // free the uv_req_t 104 | } 105 | 106 | HsInt hs_uv_udp_send(uv_udp_t* handle, const struct sockaddr* addr, char* buf, HsInt buf_siz){ 107 | uv_loop_t* loop = handle->loop; 108 | hs_loop_data* loop_data = loop->data; 109 | HsInt slot = alloc_slot(loop_data); 110 | if (slot < 0) return UV_ENOMEM; 111 | uv_udp_send_t* req = 112 | (uv_udp_send_t*)fetch_uv_struct(loop_data, slot); 113 | req->data = (void*)slot; 114 | 115 | // on windows this struct is captured by WSASend 116 | // on unix this struct is copied by libuv's uv_udp_send 117 | // so it's safe to allocate it on stack 118 | uv_buf_t buf_t = { .base = buf, .len = (size_t)buf_siz }; 119 | 120 | int r = uv_udp_send(req, handle, &buf_t, 1, addr, hs_uv_udp_send_cb); 121 | // we never use writev: we do our own 122 | // user-space buffering in haskell. 123 | if (r < 0) { 124 | free_slot(loop_data, slot); // free the uv_req_t, the callback won't fired 125 | return (HsInt)r; 126 | } else return slot; 127 | 128 | } 129 | -------------------------------------------------------------------------------- /bench/json/json-data/integers.json: -------------------------------------------------------------------------------- 1 | [1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 6, 6, 7, 7, 7, 8, 9, 9, 10, 10, 11, 12, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 23, 24, 26, 27, 29, 31, 33, 35, 37, 39, 42, 44, 47, 50, 53, 56, 60, 63, 67, 72, 76, 81, 86, 91, 96, 102, 109, 115, 122, 130, 138, 146, 155, 165, 175, 186, 197, 209, 222, 236, 250, 266, 282, 299, 318, 337, 358, 380, 403, 428, 454, 482, 511, 543, 576, 611, 649, 688, 730, 775, 823, 873, 926, 983, 1043, 1107, 1175, 1247, 1323, 1404, 1490, 1582, 1679, 1781, 1890, 2006, 2129, 2259, 2398, 2544, 2700, 2865, 3041, 3227, 3425, 3634, 3857, 4093, 4343, 4609, 4891, 5191, 5509, 5846, 6204, 6583, 6986, 7414, 7868, 8349, 8860, 9403, 9978, 10589, 11237, 11925, 12655, 13430, 14252, 15124, 16050, 17032, 18075, 19181, 20355, 21601, 22923, 24326, 25815, 27396, 29072, 30852, 32740, 34744, 36871, 39128, 41523, 44064, 46762, 49624, 52661, 55884, 59305, 62935, 66787, 70875, 75213, 79817, 84702, 89887, 95389, 101227, 107423, 113998, 120976, 128381, 136239, 144578, 153427, 162818, 172784, 183360, 194583, 206493, 219132, 232545, 246778, 261883, 277912, 294923, 312975, 332131, 352460, 374034, 396928, 421223, 447005, 474365, 503400, 534212, 566911, 601610, 638433, 677511, 718980, 762987, 809688, 859247, 911840, 967652, 1026880, 1089734, 1156434, 1227217, 1302333, 1382046, 1466638, 1556408, 1651673, 1752769, 1860052, 1973902, 2094721, 2222934, 2358996, 2503385, 2656613, 2819219, 2991777, 3174898, 3369227, 3575451, 3794297, 4026539, 4272995, 4534536, 4812086, 5106625, 5419191, 5750889, 6102889, 6476435, 6872845, 7293518, 7739939, 8213686, 8716429, 9249944, 9816115, 10416939, 11054539, 11731166, 12449207, 13211198, 14019829, 14877955, 15788605, 16754994, 17780533, 18868844, 20023768, 21249383, 22550016, 23930257, 25394980, 26949356, 28598872, 30349352, 32206975, 34178300, 36270285, 38490317, 40846232, 43346349, 45999492, 48815029, 51802899, 54973651, 58338478, 61909260, 65698602, 69719882, 73987297, 78515911, 83321713, 88421668, 93833782, 99577160, 105672079, 112140056, 119003924, 126287916, 134017747, 142220706, 150925751, 160163614, 169966908, 180370243, 191410345, 203126189, 215559137, 228753081, 242754599, 257613123, 273381107, 290114218, 307871529, 326715729, 346713346, 367934976, 390455540, 414354543, 439716356, 466630515, 495192035, 525501749, 557666661, 591800322, 628023236, 666463282, 707256166, 750545902, 796485316, 845236589, 896971830, 951873682, 1010135966, 1071964368, 1137577163, 1207205986, 1281096650, 1359510014, 1442722903, 1531029087, 1624740315, 1724187420, 1829721484, 1941715077, 2060563573, 2186686548, 2320529259, 2462564214, 2613292844, 2773247272, 2942992191, 3123126858, 3314287206, 3517148098, 3732425698, 3960880011, 4203317554, 4460594215, 4733618266, 5023353573, 5330822998, 5657112012, 6003372524, 6370826950, 6760772526, 7174585891, 7613727944, 8079749004, 8574294281, 9099109685, 9656047991, 10247075377, 10874278366, 11539871197, 12246203633, 12995769265, 13791214310, 14635346955, 15531147272, 16481777734, 17490594386, 18561158687, 19697250088, 20902879371, 22182302812, 23540037202, 24980875800, 26509905246, 28132523526, 29854459026, 31681790754, 33620969802, 35678842122, 37862672691, 40180171161, 42639519077, 45249398761, 48019023960, 50958172379, 54077220194, 57387178688, 60899733121, 64627283986, 68582990784, 72780818484, 77235586822, 81963022620, 86979815309, 92303675844, 97953399235, 103948930895, 110311437058, 117063379497, 124228594829, 131832378662, 139901574895, 148464670491, 157551896043, 167195332496, 177429024407, 188289100133, 199813899374, 212044108527, 225022904322, 238796106249, 253412338321, 268923200725, 285383451995, 302851202324, 321388118716, 341059642687, 361935221296, 384088552321, 407597844432, 432546093294, 459021374572, 487117154867, 516932621682, 548573033590, 582150091830, 617782334651, 655595555791, 695723248569, 738307077168, 783497376747, 831453684183, 882345301285, 936351892486, 993664119121, 1054484312524, 1119027188325, 1187520604468, 1260206365627, 1337341076854, 1419197049486, 1506063262491, 1598246382662, 1696071847252, 1799885012878, 1910052374747, 2026962860500, 2151029203266, 2282689398739, 2422408251457, 2570679015712, 2728025136906, 2895002099486, 3072199387991, 3260242568131, 3459795495242, 3671562657914, 3896291665080, 4134775885316, 4387857247705, 4656429214122, 4941439933460, 5243895588908, 5564863950114, 5905478142772, 6266940648935, 6650527552175, 7057593042589, 7489574197539, 7947996055022, 8434476997558, 8950734465625, 9498591020797, 10079980779998, 10696956243580, 11351695541337, 12046510122031, 12783852913581, 13566326982715, 14396694724673, 15277887615381, 16213016560543, 17205382878181, 18258489953389, 19376055606456, 20562025218016, 21820585657560, 23156180064488, 24573523533875, 26077619762337, 27673778712750, 29367635360200, 31165169585327, 33072727285306, 35097042776985, 37245262571278, 39524970602741, 41944215003394, 44511536515321, 47235998642351, 50127219647252, 53195406507421, 56451390948928, 59906667686130, 63573435001862, 67464637811456, 71594013362620, 75976139732519, 80626487293267, 85561473327514, 90798519986944, 96356115798305, 102253880934088, 108512636478302, 115154477931865, 122202853217119, 129682645456833, 137620260819954, 146043721744222, 154982765864743, 164468950997792, 174535766550465, 185218751749486, 196555621106568, 208586397563259, 221353553785311, 234902162105402, 249280053643550, 264537987166964, 280729828285480, 297912739615178, 316147382581544, 335498131574595, 356033301212013, 377825387512598, 400951323831468, 425492752460545, 451536312853150, 479173947490266, 508503226468250, 539627691953919, 572657223723034, 607708427072674, 644905044476938, 684378392439283, 726267825083707, 770721226121430, 817895530929871, 867957280587026, 921083209817197, 977460870923688, 1037289295911185, 1100779699135317, 1168156222959992, 1239656729054927, 1315533638126921, 1396054821049394, 1481504544536185, 1572184474698156, 1668414742025481, 1770535071555377, 1878905982215138, 1993910059574563, 2115953306501003, 2245466576485316, 2382907094698829, 2528760072151156, 2683540418647385, 2847794560591953] 2 | -------------------------------------------------------------------------------- /docs/index.md: -------------------------------------------------------------------------------- 1 | Design overview 2 | =============== 3 | 4 | haskell-stdio is a self contained IO toolkit for Haskell (more specifically, GHC), modules can be divided into three categories: 5 | 6 | 1. Packed data structures: 7 | 8 | + Unified `Array` interface, for many array types GHC RTS provide. 9 | 10 | - [Std.Data.Array](http://hackage.haskell.org/package/stdio/docs/Std-Data-Array.html) Unified `Array` interface, `Arr` class and many instances. 11 | - [Std.Data.Array.Checked](http://hackage.haskell.org/package/stdio/docs/Std-Data-Array-Checked.html) Bounded checked version, with exactly same API with module above. 12 | 13 | + `Vector` (array slices) operatation, including `Bytes`(word8 vectors). 14 | 15 | - [Std.Data.Vector](http://hackage.haskell.org/package/stdio/docs/Std-Data-Vector.html) `Vector` umbrella module, re-exports many things from following modules. 16 | - [Std.Data.Vector.Base](http://hackage.haskell.org/package/stdio/docs/Std-Data-Vector-Base.html) `Vec` class, `Vector` and `PrimVector` type, basic operations and instances. 17 | - [Std.Data.Vector.Extra](http://hackage.haskell.org/package/stdio/docs/Std-Data-Vector-Extra.html) Various slice manipulations, loopings and foldings. 18 | - [Std.Data.Vector.Search](http://hackage.haskell.org/package/stdio/docs/Std-Data-Vector-Search.html) KMP search on vectors! 19 | - [Std.Data.Vector.Sort](http://hackage.haskell.org/package/stdio/docs/Std-Data-Vector-Sort.html) Merge & radix sort for vectors. 20 | - [Std.Data.Vector.QQ](http://hackage.haskell.org/package/stdio/docs/Std-Data-Vector-QQ.html) Numeric vector literals. 21 | 22 | + `Builder` and `Parser` type for encoding/decoding between haskell values and `Bytes`. 23 | 24 | - [Std.Data.Builder](http://hackage.haskell.org/package/stdio/docs/Std-Data-Builder.html) `Builder` umbrella module, re-exports many things from following modules. 25 | - [Std.Data.Builder.Base](http://hackage.haskell.org/package/stdio/docs/Std-Data-Builder-Base.html) `Builder` monad type, basic builders. 26 | - [Std.Data.Builder.Numeric](http://hackage.haskell.org/package/stdio/docs/Std-Data-Builder-Numeric.html) Various numeric builders, including fast IEEE float builders! 27 | 28 | - [Std.Data.Parser](http://hackage.haskell.org/package/stdio/docs/Std-Data-Parser.html) `Parser` umbrella module, re-exports many things from following modules. 29 | - [Std.Data.Parser.Base](http://hackage.haskell.org/package/stdio/docs/Std-Data-Parser-Base.html) `Parser` monad type, basic parsers. 30 | - [Std.Data.Parser.Numeric](http://hackage.haskell.org/package/stdio/docs/Std-Data-Parser-Numeric.html) Various numeric parsers. 31 | 32 | 2. IO related stuff: 33 | 34 | + `Buffered` IO support, for reading and writing `Bytes`. 35 | 36 | - [Std.IO.Buffered](http://hackage.haskell.org/package/stdio/docs/Std-IO-Buffered.html) `Input` and `Output` device, `BufferedInput` and `BufferedOutput` operations. 37 | 38 | + Standard input and output stream. 39 | - [Std.IO.StdStream](http://hackage.haskell.org/package/stdio/docs/Std-IO-StdStream.html) `StdStream` type, and `stdin`, `stdout`, etc. 40 | 41 | + `TCP` socket support. 42 | - [Std.IO.TCP](http://hackage.haskell.org/package/stdio/docs/Std-IO-TCP.html) Fast TCP client and server. 43 | 44 | + `FileSystem` support, with special path type `CBytes`. 45 | - [Std.Data.CBytes](http://hackage.haskell.org/package/stdio/docs/Std-Data-TCP.CBytes) Null terminated `CBytes`, suitable for file path, system FFI, etc. 46 | - [Std.IO.FileSystem](http://hackage.haskell.org/package/stdio/docs/Std-IO-FileSystem.html) File system operations implemented with unsafe FFI. 47 | - [Std.IO.FileSystemT](http://hackage.haskell.org/package/stdio/docs/Std-IO-FileSystem.html) File system operations implemented with libuv's threadpool. 48 | 49 | + Simple yet fast `Logger`. 50 | - [Std.IO.Logger](http://hackage.haskell.org/package/stdio/docs/Std-IO-FileSystem.html) Simple fast and thread safe logger. 51 | 52 | + High performance low resolution timers. 53 | - [Std.IO.LowResTimer](http://hackage.haskell.org/package/stdio/docs/Std-IO-LowResTimer.html) Low resolutioin (0.1s) timer, `timeout`, `throttle`, etc. 54 | 55 | + Resource management and exceptions. 56 | - [Std.IO.Resource](http://hackage.haskell.org/package/stdio/docs/Std-IO-Resource.html) `Resource` monad for safely using a resource. 57 | - [Std.IO.Exception](http://hackage.haskell.org/package/stdio/docs/Std-IO-Exception.html) `Control.Exception` replacement. 58 | 59 | 3. Internal modules for hackers: 60 | 61 | + High performance IO management built upon libuv and GHC RTS. 62 | 63 | - [Std.IO.UV.Manager](http://hackage.haskell.org/package/stdio/docs/Std-IO-UV-Manager.html) Our standalone IO manager based on libuv event loop. 64 | - [Std.IO.UV.Errno](http://hackage.haskell.org/package/stdio/docs/Std-IO-UV-Errno.html) Defination of all libuv's errno. 65 | - [Std.IO.UV.FFI](http://hackage.haskell.org/package/stdio/docs/Std-IO-UV-Errno.html) Foreign imports of all libuv's FFI. 66 | 67 | Currently we also have plans to support more things such as JSON protocols, UDP socket, etc, which will also built upon works above. Basically we focus on engineering infrastructure only. Please join in! 68 | 69 | Related material 70 | ---------------- 71 | 72 | We have published a [paper](https://dl.acm.org/citation.cfm?id=3242759) on our IO manager at Haskell Symposium 2018, it's available [here](https://github.com/haskell-stdio/stdio/blob/master/docs/A%20High-Performance%20Multicore%20IO%20Manager%20Based%20on%20libuv%20(Experience%20Report).pdf). 73 | 74 | Here is a video recorded @shenzhen chinese haskell meeting by @winterland1989, it explains almost every detail how do we combine GHC's lightweight thread with libuv's event loop in haskell-stdio. 75 | 76 | [![libuv based I/O manager](https://img.youtube.com/vi/2J0fGMpFA_w/0.jpg)](https://youtu.be/2J0fGMpFA_w) 77 | -------------------------------------------------------------------------------- /bench/json/json-data/twitter10.json: -------------------------------------------------------------------------------- 1 | {"results":[{"from_user_id_str":"207858021","profile_image_url":"http://a3.twimg.com/sticky/default_profile_images/default_profile_2_normal.png","created_at":"Wed, 26 Jan 2011 04:30:38 +0000","from_user":"pboudarga","id_str":"30120402839666689","metadata":{"result_type":"recent"},"to_user_id":null,"text":"I'm at Rolla Sushi Grill (27737 Bouquet Canyon Road, #106, Btw Haskell Canyon and Rosedell Drive, Saugus) http://4sq.com/gqqdhs","id":30120402839666689,"from_user_id":207858021,"geo":null,"iso_language_code":"en","to_user_id_str":null,"source":"<a href="http://foursquare.com" rel="nofollow">foursquare</a>"},{"from_user_id_str":"69988683","profile_image_url":"http://a0.twimg.com/profile_images/1211955817/avatar_7888_normal.gif","created_at":"Wed, 26 Jan 2011 04:25:23 +0000","from_user":"YNK33","id_str":"30119083059978240","metadata":{"result_type":"recent"},"to_user_id":null,"text":"hsndfile 0.5.0: Free and open source Haskell bindings for libsndfile http://bit.ly/gHaBWG Mac Os","id":30119083059978240,"from_user_id":69988683,"geo":null,"iso_language_code":"en","to_user_id_str":null,"source":"<a href="http://twitterfeed.com" rel="nofollow">twitterfeed</a>"},{"from_user_id_str":"81492","profile_image_url":"http://a1.twimg.com/profile_images/423894208/Picture_7_normal.jpg","created_at":"Wed, 26 Jan 2011 04:24:28 +0000","from_user":"satzz","id_str":"30118851488251904","metadata":{"result_type":"recent"},"to_user_id":null,"text":"Emacs\u306e\u30e2\u30fc\u30c9\u8868\u793a\u304c\u4eca(Ruby Controller Outputz RoR Flymake REl hs)\u3068\u306a\u3063\u3066\u3066\u3088\u304f\u308f\u304b\u3089\u306a\u3044\u3093\u3060\u3051\u3069\u6700\u5f8c\u306eREl\u3068\u304bhs\u3063\u3066\u4f55\u3060\u308d\u3046\u2026haskell\u3068\u304b2\u5e74\u4ee5\u4e0a\u66f8\u3044\u3066\u306a\u3044\u3051\u3069\u2026","id":30118851488251904,"from_user_id":81492,"geo":null,"iso_language_code":"ja","to_user_id_str":null,"source":"<a href="http://www.hootsuite.com" rel="nofollow">HootSuite</a>"},{"from_user_id_str":"9518356","profile_image_url":"http://a2.twimg.com/profile_images/119165723/ocaml-icon_normal.png","created_at":"Wed, 26 Jan 2011 04:19:19 +0000","from_user":"planet_ocaml","id_str":"30117557788741632","metadata":{"result_type":"recent"},"to_user_id":null,"text":"I so miss #haskell type classes in #ocaml - i want to do something like refinement. Also why does ocaml not have... http://bit.ly/geYRwt","id":30117557788741632,"from_user_id":9518356,"geo":null,"iso_language_code":"en","to_user_id_str":null,"source":"<a href="http://twitterfeed.com" rel="nofollow">twitterfeed</a>"},{"from_user_id_str":"218059","profile_image_url":"http://a1.twimg.com/profile_images/1053837723/twitter-icon9_normal.jpg","created_at":"Wed, 26 Jan 2011 04:16:32 +0000","from_user":"aprikip","id_str":"30116854940835840","metadata":{"result_type":"recent"},"to_user_id":null,"text":"yatex-mode\u3084haskell-mode\u306e\u3053\u3068\u3067\u3059\u306d\u3001\u308f\u304b\u308a\u307e\u3059\u3002","id":30116854940835840,"from_user_id":218059,"geo":null,"iso_language_code":"ja","to_user_id_str":null,"source":"<a href="http://sites.google.com/site/yorufukurou/" rel="nofollow">YoruFukurou</a>"},{"from_user_id_str":"216363","profile_image_url":"http://a1.twimg.com/profile_images/72454310/Tim-Avatar_normal.png","created_at":"Wed, 26 Jan 2011 04:15:30 +0000","from_user":"dysinger","id_str":"30116594684264448","metadata":{"result_type":"recent"},"to_user_id":null,"text":"Haskell in Hawaii tonight for me... #fun","id":30116594684264448,"from_user_id":216363,"geo":null,"iso_language_code":"en","to_user_id_str":null,"source":"<a href="http://www.nambu.com/" rel="nofollow">Nambu</a>"},{"from_user_id_str":"1774820","profile_image_url":"http://a2.twimg.com/profile_images/61169291/dan_desert_thumb_normal.jpg","created_at":"Wed, 26 Jan 2011 04:13:36 +0000","from_user":"DanMil","id_str":"30116117682851840","metadata":{"result_type":"recent"},"to_user_id":1594784,"text":"@ojrac @chewedwire @tomheon Haskell isn't a language, it's a belief system. A seductive one...","id":30116117682851840,"from_user_id":1774820,"to_user":"ojrac","geo":null,"iso_language_code":"en","to_user_id_str":"1594784","source":"<a href="http://twitter.com/">web</a>"},{"from_user_id_str":"659256","profile_image_url":"http://a0.twimg.com/profile_images/746976711/angular-final_normal.jpg","created_at":"Wed, 26 Jan 2011 04:11:06 +0000","from_user":"djspiewak","id_str":"30115488931520512","metadata":{"result_type":"recent"},"to_user_id":null,"text":"One of the very nice things about Haskell as opposed to SML is the reduced proliferation of identifiers (e.g. andb, orb, etc). #typeclasses","id":30115488931520512,"from_user_id":659256,"geo":null,"iso_language_code":"en","to_user_id_str":null,"source":"<a href="http://itunes.apple.com/us/app/twitter/id409789998?mt=12" rel="nofollow">Twitter for Mac</a>"},{"from_user_id_str":"144546280","profile_image_url":"http://a1.twimg.com/a/1295051201/images/default_profile_1_normal.png","created_at":"Wed, 26 Jan 2011 04:06:12 +0000","from_user":"listwarenet","id_str":"30114255890026496","metadata":{"result_type":"recent"},"to_user_id":null,"text":"http://www.listware.net/201101/haskell-cafe/84752-re-haskell-cafe-gpl-license-of-h-matrix-and-prelude-numeric.html Re: Haskell-c","id":30114255890026496,"from_user_id":144546280,"geo":null,"iso_language_code":"no","to_user_id_str":null,"source":"<a href="http://1e10.org/cloud/" rel="nofollow">1e10</a>"},{"from_user_id_str":"1594784","profile_image_url":"http://a2.twimg.com/profile_images/378515773/square-profile_normal.jpg","created_at":"Wed, 26 Jan 2011 04:01:29 +0000","from_user":"ojrac","id_str":"30113067333324800","metadata":{"result_type":"recent"},"to_user_id":null,"text":"RT @tomheon: @ojrac @chewedwire Don't worry, learning Haskell will not give you any clear idea what monad means.","id":30113067333324800,"from_user_id":1594784,"geo":null,"iso_language_code":"en","to_user_id_str":null,"source":"<a href="http://twitter.com/">web</a>"}],"max_id":30120402839666689,"since_id":0,"refresh_url":"?since_id=30120402839666689&q=haskell","next_page":"?page=2&max_id=30120402839666689&rpp=10&q=haskell","results_per_page":10,"page":1,"completed_in":0.012714,"since_id_str":"0","max_id_str":"30120402839666689","query":"haskell"} 2 | -------------------------------------------------------------------------------- /std-data/Std/Data/Vector.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE BangPatterns #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE MagicHash #-} 10 | {-# LANGUAGE CPP #-} 11 | {-# LANGUAGE CApiFFI #-} 12 | {-# LANGUAGE ViewPatterns #-} 13 | {-# LANGUAGE UnliftedFFITypes #-} 14 | {-# LANGUAGE PatternSynonyms #-} 15 | {-# LANGUAGE TemplateHaskell #-} 16 | {-# LANGUAGE QuasiQuotes #-} 17 | 18 | {-| 19 | Module : Std.Data.Vector 20 | Description : Fast boxed and unboxed vector 21 | Copyright : (c) Dong Han, 2017-2018 22 | License : BSD 23 | Maintainer : winterland1989@gmail.com 24 | Stability : experimental 25 | Portability : non-portable 26 | 27 | This module provide fast boxed and unboxed vector with unified interface. 28 | The API is similar to bytestring and vector. If you find missing functions, please report! 29 | 30 | Performance consideration: 31 | 32 | * Use 'PrimVector' for 'Prim' types, it stores content in packed memory, and it's 33 | strict on its elements (following strictness consideration are mainly for lifted 34 | 'Vector' type), many functions DO NOT NEED the result vectors's type to be same 35 | with the source one, e.g. @map :: (Vec v a, Vec u b) => (a -> b) -> v a -> u b@. 36 | 37 | * There're some specialized function which only works on 'Bytes', which is enabled 38 | with rewrite rules, if you want to use specialized versions directly, import 39 | "Std.Data.Vector.Base" and "Std.Data.Vector.Extra" module. Doing so will also 40 | enable vector internals, which is useful for working on the underlying arrays. 41 | 42 | * The 'Functor' instance for 'Vector' are lazy in order to abid 'Functor' law. 43 | namely @fmap id vectorConatinBottom == vectorContainBottom@, if you need strict mapping 44 | for lifted 'Vector', use 'map'' ('PrimVector' will never contain bottom thus it's not 45 | a problem). THIS MAY COME AS A SURPRISE SO MAKE SURE YOU USE THE CORRECT 'map' s. 46 | 47 | * The 'Foldable' instance for 'Vector' is fine, use 'Prelude' functions such as 48 | 'null', 'length', etc. should not incur performance overhead, though there're 49 | partial functions you should avoid, i.e. foldl1, foldr1, maximum, minimum. Use 50 | 'foldl1Maybe'', 'foldr1Maybe'', 'maximumMaybe', 'minmumMaybe' instead. 51 | 52 | * The 'Traversable' instance have specialized implementations for 'ST' and 'IO', 53 | if you don't want to write thunks into result vector, use @return <$!>@ idiom. 54 | 55 | * When use stateful generating functions like 'mapAccumL', 'mapAccumR' ,etc. force 56 | both the accumulator and value with @acc `seq` v `seq` (acc, v)@ idiom to avoid 57 | thunks inside result vector. 58 | 59 | * The 'unpack', 'unpackR' and 'pack', 'packN', 'packR', 'packRN' are designed to 60 | work with @build/foldr@ streaming fusion in base, thus it's OK to expect idioms like 61 | 62 | > pack . List filter f . List.map . unpack 63 | 64 | to work in contant space. While 65 | 66 | > Vector.filter . Vector.map 67 | 68 | will create intermediate vectors on the fly, which have different time/space characteristic. 69 | 70 | Since all functions works on more general types, inlining and specialization are the keys 71 | to achieve high performance, e.g. the performance gap between running in GHCi and 72 | compiled binary may be huge due to dictionary passing. If there're cases that GHC fail to 73 | specialized these functions, it should be regarded as a bug either in this library or GHC. 74 | 75 | -} 76 | 77 | module Std.Data.Vector ( 78 | -- * The Vec typeclass 79 | Vec(IArray, MArray) 80 | -- * Boxed and unboxed vector type 81 | , Vector 82 | , PrimVector 83 | -- ** Word8 vector 84 | , Bytes, packASCII 85 | -- * Basic creating 86 | , empty, singleton, copy 87 | -- * Conversion between list 88 | , pack, packN, packR, packRN 89 | , unpack, unpackR 90 | -- * Basic interface 91 | , null 92 | , length 93 | , append 94 | , map, map', imap', traverseVec, traverseWithIndex, traverseVec_, traverseWithIndex_ 95 | , foldl', ifoldl', foldl1', foldl1Maybe' 96 | , foldr', ifoldr', foldr1', foldr1Maybe' 97 | -- ** Special folds 98 | , concat, concatMap 99 | , maximumMaybe, minimumMaybe 100 | , sum 101 | , count 102 | , product, product' 103 | , all, any 104 | -- * Building vector 105 | -- ** Accumulating maps 106 | , mapAccumL 107 | , mapAccumR 108 | -- ** Generating and unfolding vector 109 | , replicate 110 | , cycleN 111 | , unfoldr 112 | , unfoldrN 113 | -- * Searching by equality 114 | , elem, notElem, elemIndex 115 | -- * Slice manipulation 116 | , cons, snoc 117 | , uncons, unsnoc 118 | , headMaybe, tailMayEmpty 119 | , lastMaybe, initMayEmpty 120 | , inits, tails 121 | , take, drop, takeR, dropR 122 | , slice 123 | , splitAt 124 | , takeWhile, takeWhileR, dropWhile, dropWhileR, dropAround 125 | , break, span, breakR, spanR, breakOn 126 | , group, groupBy 127 | , stripPrefix, stripSuffix 128 | , split, splitWith, splitOn 129 | , isPrefixOf, isSuffixOf, isInfixOf 130 | , commonPrefix 131 | , words, lines, unwords, unlines 132 | , padLeft, padRight 133 | -- * Transform 134 | , reverse 135 | , intersperse 136 | , intercalate 137 | , intercalateElem 138 | , transpose 139 | -- * Zipping 140 | , zipWith', unzipWith' 141 | -- * Scans 142 | , scanl', scanl1' 143 | , scanr', scanr1' 144 | -- * Search 145 | -- ** element-wise search 146 | , find, findR 147 | , findIndices, elemIndices 148 | , filter, partition 149 | -- ** sub-vector search 150 | , indicesOverlapping 151 | , indices 152 | -- * Sort 153 | -- ** comparison search 154 | , mergeSort 155 | , mergeSortBy 156 | , mergeTileSize 157 | , insertSort 158 | , insertSortBy 159 | , Down(..) 160 | -- ** radix search 161 | , radixSort 162 | , Radix(..) 163 | , RadixDown(..) 164 | -- * QuasiQuoters 165 | , ascii 166 | , vecW8, vecW16, vecW32, vecW64, vecWord 167 | , vecI8, vecI16, vecI32, vecI64, vecInt 168 | -- * Misc 169 | , IPair(..) 170 | , VectorException(..) 171 | , castVector 172 | ) where 173 | 174 | import Prelude () 175 | import Std.Data.Vector.Base 176 | import Std.Data.Vector.Extra 177 | import Std.Data.Vector.Search 178 | import Std.Data.Vector.Sort 179 | import Std.Data.Vector.QQ 180 | -------------------------------------------------------------------------------- /std-data/Std/Data/Array/Compound.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE UnboxedTuples #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE DeriveDataTypeable #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | 10 | {-| 11 | Module : Std.Data.Array.Checked 12 | Description : Bounded checked boxed and unboxed arrays 13 | Copyright : (c) Dong Han, 2019 14 | License : BSD 15 | Maintainer : winterland1989@gmail.com 16 | Stability : experimental 17 | Portability : non-portable 18 | 19 | This module provides 'CompoundArray', i.e. array composed with two different type of arrays. It provides different memory characteristic from array of tuples. e.g. the memory layout of @Array (Int, Foo)@ may looks like this: 20 | 21 | @ 22 | +-----+---+ +------+---+---+---- 23 | |Array| * +-->+Array#| # | * | ... 24 | +-----+---+ +------+---+-+-+---- 25 | | 26 | V 27 | +-+-+---+---+ +---+----- 28 | |(,)| * | * +--->+Foo| ... 29 | +---+-+-+---+ +---+----- 30 | | 31 | V 32 | +-+-+---+ 33 | |Int| # | 34 | +---+-+-+ 35 | @ 36 | 37 | With @CompoundArray PrimArray Array (Int, Foo)@, things turn into: 38 | 39 | @ 40 | 41 | +---------------+---+---+ +-----+---+---+---- 42 | | CompoundArray | * | * +-->+Array| # | * | ... 43 | +---------------+-+-+---+ +-----+---+-+-+---- 44 | | | +---+----- 45 | | +------>|Foo| ... 46 | | 47 | V 48 | +---------+---+---+---- 49 | |PrimArray| * + * | ... 50 | +---------+-+-+-+-+---- 51 | @ 52 | 53 | So 54 | 55 | -} 56 | module Std.Data.Array.Compound where 57 | 58 | import Std.Data.Array 59 | import Control.Applicative 60 | import Data.Data 61 | import Data.Typeable 62 | 63 | -- Instead of providing a generalized compound array with polymorphric array fields, we use this typeclass 64 | -- so that instances use concrete array type can unpack their array payload. 65 | class (Arr marrA arrA a, Arr marrB arrB b) => CompoundArr marr arr a b | marr -> arr, arr -> marr where 66 | composedArr :: arrA a -> arrB b -> arr a b 67 | composedMutArr :: marrA s a -> marrB s b -> marr s a b 68 | 69 | data CompoundArrayArray x y = CompoundArrayArray (Array x) (Array y) 70 | data CompoundMutableArrayArray s x y = CompoundMutableArrayArray (MutableArray s x) (MutableArray s y) 71 | 72 | 73 | instance (CompoundArr marr arr a b) 74 | => Arr (MutableCompoundArray marrA marrB) (CompoundArray arrA arrB) (x, y) where 75 | type MArr (CompoundArray arrA arrB) = MutableCompoundArray (MArr arrA) (MArr arrB) 76 | type IArr (MutableCompoundArray marrA marrB) = CompoundArray (IArr marrA) (IArr marrB) 77 | 78 | newArr n = liftA2 MutableCompoundArray (newArr n) (newArr n) 79 | {-# INLINE newArr #-} 80 | newArrWith n (x,y) = liftA2 MutableCompoundArray (newArrWith n x) (newArrWith n y) 81 | {-# INLINE newArrWith #-} 82 | readArr (MutableCompoundArray marrA marrB) i = liftA2 (,) (readArr marrA i) (readArr marrB i) 83 | {-# INLINE readArr #-} 84 | writeArr (MutableCompoundArray marrA marrB) i (x,y) = do 85 | writeArr marrA i x 86 | writeArr marrB i y 87 | {-# INLINE writeArr #-} 88 | setArr (MutableCompoundArray marrA marrB) s l (x,y) = do 89 | setArr marrA s l x 90 | setArr marrB s l y 91 | {-# INLINE setArr #-} 92 | indexArr (CompoundArray arrA arrB) i = (indexArr arrA i, indexArr arrB i) 93 | {-# INLINE indexArr #-} 94 | indexArr' (CompoundArray arrA arrB) i = 95 | let (# x #) = indexArr' arrA i 96 | (# y #) = indexArr' arrB i 97 | in (# (x,y) #) 98 | {-# INLINE indexArr' #-} 99 | indexArrM (CompoundArray arrA arrB) i = liftA2 (,) (indexArrM arrA i) (indexArrM arrB i) 100 | {-# INLINE indexArrM #-} 101 | freezeArr (MutableCompoundArray marrA marrB) i j = 102 | liftA2 CompoundArray (freezeArr marrA i j) (freezeArr marrB i j) 103 | {-# INLINE freezeArr #-} 104 | thawArr (CompoundArray arrA arrB) i j = 105 | liftA2 MutableCompoundArray (thawArr arrA i j) (thawArr arrB i j) 106 | {-# INLINE thawArr #-} 107 | unsafeFreezeArr (MutableCompoundArray marrA marrB) = 108 | liftA2 CompoundArray (unsafeFreezeArr marrA) (unsafeFreezeArr marrB) 109 | {-# INLINE unsafeFreezeArr #-} 110 | unsafeThawArr (CompoundArray arrA arrB) = 111 | liftA2 MutableCompoundArray (unsafeThawArr arrA) (unsafeThawArr arrB) 112 | {-# INLINE unsafeThawArr #-} 113 | 114 | copyArr (MutableCompoundArray marrA marrB) s (CompoundArray arrA arrB) i j = do 115 | copyArr marrA s arrA i j 116 | copyArr marrB s arrB i j 117 | {-# INLINE copyArr #-} 118 | 119 | copyMutableArr (MutableCompoundArray marrA marrB) s (MutableCompoundArray marrC marrD) i j = do 120 | copyMutableArr marrA s marrC i j 121 | copyMutableArr marrB s marrD i j 122 | {-# INLINE copyMutableArr #-} 123 | 124 | moveArr (MutableCompoundArray marrA marrB) s (MutableCompoundArray marrC marrD) i j = do 125 | moveArr marrA s marrC i j 126 | moveArr marrB s marrD i j 127 | {-# INLINE moveArr #-} 128 | 129 | cloneArr (CompoundArray arrA arrB) s l = 130 | CompoundArray (cloneArr arrA s l) (cloneArr arrB s l) 131 | {-# INLINE cloneArr #-} 132 | 133 | cloneMutableArr (MutableCompoundArray marrA marrB) s l = 134 | liftA2 MutableCompoundArray (cloneMutableArr marrA s l) (cloneMutableArr marrB s l) 135 | {-# INLINE cloneMutableArr #-} 136 | 137 | resizeMutableArr (MutableCompoundArray marrA marrB) n = 138 | liftA2 MutableCompoundArray (resizeMutableArr marrA n) (resizeMutableArr marrB n) 139 | {-# INLINE resizeMutableArr #-} 140 | 141 | shrinkMutableArr (MutableCompoundArray marrA marrB) n = do 142 | shrinkMutableArr marrA n 143 | shrinkMutableArr marrB n 144 | {-# INLINE shrinkMutableArr #-} 145 | 146 | sameMutableArr (MutableCompoundArray marrA marrB) (MutableCompoundArray marrC marrD) = 147 | sameMutableArr marrA marrC && sameMutableArr marrB marrD 148 | {-# INLINE sameMutableArr #-} 149 | 150 | -- two array part should have same size 151 | sizeofArr (CompoundArray arrA _) = sizeofArr arrA 152 | {-# INLINE sizeofArr #-} 153 | sizeofMutableArr (MutableCompoundArray marrA marrB) = sizeofMutableArr marrA 154 | {-# INLINE sizeofMutableArr #-} 155 | 156 | sameArr (CompoundArray arrA arrB) (CompoundArray arrC arrD) = 157 | sameArr arrA arrC && sameArr arrB arrD 158 | {-# INLINE sameArr #-} 159 | --------------------------------------------------------------------------------