diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 philopon + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/main.hs b/bench/main.hs new file mode 100644 --- /dev/null +++ b/bench/main.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Criterion.Main + +import Data.ByteString(ByteString) +import qualified Data.ByteString.Char8 as SC + +import qualified Data.Text.Encoding as T + +import Data.Scientific(toRealFloat) +import Data.String(IsString) + +import qualified Data.ByteString.Read as R +import qualified Data.Text.Read as T +import qualified Data.ByteString.Lex.Double as L +import qualified Data.Attoparsec.ByteString.Char8 as A + +short :: ByteString +short = "-2342395232123424.3424346343524e3" + +long :: ByteString +long = "-234232345678976521345895325678987654321345678987654321345689643213595232123424.34243463435223456789321367899231808534492500740957389523850293482093852039587495203586329850238562834290374029844e3" + +checkConsumed :: (IsString a, Eq a) => (v, a) -> v +checkConsumed (d, "") = d +checkConsumed _ = error "not consumed" + +bytestringRead :: ByteString -> Double +bytestringRead = maybe (error "parse error") checkConsumed . R.signed R.floating + +text :: ByteString -> Double +text = either (const $ error "parse error") checkConsumed . T.signed T.double . T.decodeUtf8 + +bytestringLexing :: ByteString -> Double +bytestringLexing = maybe (error "parse error") checkConsumed . L.readDouble + +attoparsec :: ByteString -> Double +attoparsec = either (const $ error "parse error") id . A.parseOnly (fmap toRealFloat A.scientific) + +read' :: ByteString -> Double +read' = read . SC.unpack + +doBench :: String -> (ByteString -> Double) -> Benchmark +doBench n f = bgroup n + [ bench "short" $ nf f short + , bench "long" $ nf f long + ] + +main :: IO () +main = defaultMain + [ doBench "bytestring-read" bytestringRead + , doBench "text" text + , doBench "bytestring-lexing" bytestringLexing + , doBench "attoparsec" attoparsec + , doBench "read" read' + ] diff --git a/bytestring-read.cabal b/bytestring-read.cabal new file mode 100644 --- /dev/null +++ b/bytestring-read.cabal @@ -0,0 +1,56 @@ +name: bytestring-read +version: 0.1.0 +synopsis: fast ByteString to Double converting library +description: benchmark: +license: MIT +license-file: LICENSE +author: HirotomoMoriwaki +maintainer: HirotomoMoriwaki +Homepage: https://github.com/philopon/bytestring-read +Bug-reports: https://github.com/philopon/bytestring-read/issues +copyright: (c) 2015 Hirotomo Moriwaki +category: Data +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Data.ByteString.Read + build-depends: base >=4.6 && <4.8 + , bytestring >=0.10 && <0.11 + , types-compat >=0.1 && <0.2 + hs-source-dirs: src + ghc-options: -Wall -O2 + default-language: Haskell2010 + +benchmark bench + type: exitcode-stdio-1.0 + main-is: bench/main.hs + build-depends: base + , bytestring-read + , bytestring >=0.10 && <0.11 + , text + , bytestring-lexing >=0.4 && <0.5 + , criterion >=1.0 && <1.1 + , scientific + , attoparsec + ghc-options: -Wall -O2 + default-language: Haskell2010 + +test-suite tasty + type: exitcode-stdio-1.0 + main-is: tests/tasty.hs + build-depends: base + , bytestring-read + , bytestring >=0.10 && <0.11 + , tasty >=0.10 && <0.11 + , tasty-quickcheck >=0.8 && <0.9 + ghc-options: -Wall -O2 + default-language: Haskell2010 + +test-suite doctests + type: exitcode-stdio-1.0 + ghc-options: -threaded + main-is: tests/doctest.hs + build-depends: base >=4.6 && <4.8 + , doctest >=0.9 && <0.10 + default-language: Haskell2010 diff --git a/src/Data/ByteString/Read.hs b/src/Data/ByteString/Read.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Read.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-} + +module Data.ByteString.Read + ( -- * functions + floating + , double + , signed + + -- * classes + , EffectiveDigit(..) + , Base(..) + + -- * raw functions + , floating10 + , floating' + ) where + +import Control.Arrow(first) +import Control.Applicative((<$>)) + +import Data.ByteString.Unsafe +import Data.ByteString(ByteString) +import qualified Data.ByteString as S +import Data.Word + +import GHC.TypeLits.Compat +import Data.Proxy.Compat + +-- $setup +-- >>> :set -XDataKinds -XOverloadedStrings + +minus :: Word8 +minus = 45 +{-# INLINE minus #-} + +plus :: Word8 +plus = 43 +{-# INLINE plus #-} + + +class (Fractional a, Num (Fraction a), Ord (Fraction a)) => EffectiveDigit a where + -- | data type to store fractional part of floating + data Fraction a + + -- | maximum value of fractional part. + -- + -- Nothing if arbitrary-precision. + -- + -- @ + -- Just $ fromIntegral (floatRadix t) ^ floatDigits t + -- @ + maxValue :: proxy a -> Maybe (Fraction a) + + -- | lifted fromIntegral + fromFraction :: Num b => Fraction a -> b + +instance EffectiveDigit Float where + newtype Fraction Float = FractionFloat Word32 + deriving(Eq, Ord, Num) + + maxValue _ = let t = 0 :: Float in Just $ fromIntegral (floatRadix t) ^ floatDigits t + fromFraction (FractionFloat a) = fromIntegral a + + {-# INLINE maxValue #-} + {-# INLINE fromFraction #-} + +instance EffectiveDigit Double where + newtype Fraction Double = FractionDouble Word64 + deriving(Eq, Ord, Num) + + maxValue _ = let t = 0 :: Double in Just $ fromIntegral (floatRadix t) ^ floatDigits t + fromFraction (FractionDouble a) = fromIntegral a + + {-# INLINE maxValue #-} + {-# INLINE fromFraction #-} + +instance EffectiveDigit Rational where + newtype Fraction Rational = WordRational Integer + deriving(Eq, Ord, Num) + + maxValue _ = Nothing + fromFraction (WordRational a) = fromIntegral a + + {-# INLINE maxValue #-} + {-# INLINE fromFraction #-} + +class KnownNat n => Base n where + -- | check input Word8 is digit charactor or not. + isDigit :: proxy n -> Word8 -> Bool + + -- | convert digit charactor to number. + -- undefined behaviour when give non-digit charactor. + unsafeToDigit :: proxy n -> Word8 -> Word8 + +#define defineBaseUnder10(BASE, MAX)\ +instance Base BASE where;\ + {-# INLINE isDigit #-};\ + {-# INLINE unsafeToDigit #-};\ + isDigit _ = \w -> 48 <= w && w <= MAX;\ + unsafeToDigit _ w = w - 48 + +defineBaseUnder10( 2, 49) +defineBaseUnder10( 3, 50) +defineBaseUnder10( 4, 51) +defineBaseUnder10( 5, 52) +defineBaseUnder10( 6, 53) +defineBaseUnder10( 7, 54) +defineBaseUnder10( 8, 55) +defineBaseUnder10( 9, 56) +defineBaseUnder10(10, 57) + +#define defineBaseOver10(BASE, MAXu, MAXl)\ +instance Base BASE where;\ + {-# INLINE isDigit #-};\ + {-# INLINE unsafeToDigit #-};\ + isDigit _ = \w -> 48 <= w && w <= 57 || 65 <= w && w <= MAXu || 97 <= w && w <= MAXl;\ + unsafeToDigit _ w = if 48 <= w && w <= 57;\ + then fromIntegral w - 48;\ + else if 65 <= w && w <= 90;\ + then fromIntegral w - 55;\ + else fromIntegral w - 87 + +defineBaseOver10(11, 65, 97) +defineBaseOver10(12, 66, 98) +defineBaseOver10(13, 67, 99) +defineBaseOver10(14, 68, 100) +defineBaseOver10(15, 69, 101) +defineBaseOver10(16, 70, 102) +defineBaseOver10(17, 71, 103) +defineBaseOver10(18, 72, 104) +defineBaseOver10(19, 73, 105) +defineBaseOver10(20, 74, 106) +defineBaseOver10(21, 75, 107) +defineBaseOver10(22, 76, 108) +defineBaseOver10(23, 77, 109) +defineBaseOver10(24, 78, 110) +defineBaseOver10(25, 79, 111) +defineBaseOver10(26, 80, 112) +defineBaseOver10(27, 81, 113) +defineBaseOver10(28, 82, 114) +defineBaseOver10(29, 83, 115) +defineBaseOver10(30, 84, 116) +defineBaseOver10(31, 85, 117) +defineBaseOver10(32, 86, 118) +defineBaseOver10(33, 87, 119) +defineBaseOver10(34, 88, 120) +defineBaseOver10(35, 89, 121) +defineBaseOver10(36, 90, 122) + + +integral :: forall proxy n r. (Base n, EffectiveDigit r, Ord (Fraction r), Num (Fraction r)) + => proxy n -> ByteString -> (Fraction r, Int, Int, ByteString) +integral pn = loop 0 0 0 + where + pr :: Proxy r + pr = Proxy + + loop !i !d !ad !s + | S.null s = (i, d, ad, s) + | not (isDigit pn (unsafeHead s)) = (i, d, ad, s) + | maybe False (i >=) (maxValue pr) = loop i d (ad + 1) (unsafeTail s) + | otherwise = loop + (i * fromIntegral (natVal pn) + (fromIntegral $ unsafeToDigit pn (unsafeHead s) :: Fraction r)) + (d+1) ad (unsafeTail s) +{-# INLINABLE integral #-} + +toFractional :: (Base b, EffectiveDigit r, Fractional r) + => proxy b -> Fraction r -> Fraction r -> Int -> Int -> r +toFractional p q r du d = fromFraction q * base ^ du + fromFraction r / base ^ d + where + base = fromIntegral (natVal p) +{-# INLINABLE toFractional #-} + +-- | convert bytestring into unsigned floating using radix. +-- +-- this function can parse +-- +-- * floating(0.1, 12224.3543) +-- +-- >>> floating' (Proxy :: Proxy 36) "12z" :: Maybe (Double, ByteString) +-- Just (1403.0,"") +-- >>> floating' (Proxy :: Proxy 2) "1012" :: Maybe (Double, ByteString) +-- Just (5.0,"2") +-- >>> floating' (Proxy :: Proxy 10) "a12" :: Maybe (Double, ByteString) +-- Nothing +floating' :: (Base b, EffectiveDigit r) => proxy b -> ByteString -> Maybe (r, ByteString) +floating' pn s = case integral pn s of + (_, 0, _, _) -> Nothing + (q, _, d, "") -> Just (fromFraction q * fromIntegral (natVal pn) ^ d, "") + (q, _, d, s1) + | unsafeHead s1 /= dot -> Just (fromFraction q, s1) + | otherwise -> case integral pn (unsafeTail s1) of + (_, 0, _, _) -> Just (fromFraction q, s1) + (r, d', _, s2) -> Just (toFractional pn q r d d', s2) + where + dot = 46 +{-# INLINABLE floating' #-} + +exponential :: forall proxy r. (EffectiveDigit r, Ord (Fraction r), Num (Fraction r)) + => proxy r -> ByteString -> (Int, ByteString) +exponential _ s0 + | S.null s0 = (0, s0) + | isE (unsafeHead s0) = sign (unsafeTail s0) + | otherwise = (0, s0) + where + isE w = w == 101 || w == 69 + + sign s1 + | S.null s1 = (0, s0) + | unsafeHead s1 == plus = expPart $ unsafeTail s1 + | unsafeHead s1 == minus = let (e, s) = expPart $ unsafeTail s1 in (-e, s) + | otherwise = expPart s1 + + expPart s2 = case integral (Proxy :: Proxy 10) s2 :: (Fraction r, Int, Int, ByteString) of + (_, 0, _, _) -> (0, s0) + (e, _, _, s) -> (fromFraction e, s) +{-# INLINABLE exponential #-} + +setExpPart :: Fractional f => Int -> f -> f +setExpPart e f + | e >= 0 = f * 10 ^ e + | otherwise = f / 10 ^ abs e +{-# SPECIALIZE setExpPart :: Int -> Double -> Double #-} +{-# SPECIALIZE setExpPart :: Int -> Float -> Float #-} +{-# INLINABLE setExpPart #-} + +-- | convert bytestring into unsigned floating using radix. +-- +-- this function can parse +-- +-- * floating(0.1, 12224.3543) +-- * exponential (e1, E+2, e-123) (optional) +-- +-- >>> floating10 "12.5" :: Maybe (Double, ByteString) +-- Just (12.5,"") +-- >>> floating10 "124.1e12" :: Maybe (Double, ByteString) +-- Just (1.241e14,"") +-- >>> floating10 "12.5e-3" :: Maybe (Double, ByteString) +-- Just (1.25e-2,"") +-- >>> floating10 "3.11e+3" :: Maybe (Double, ByteString) +-- Just (3110.0,"") +floating10 :: forall r. EffectiveDigit r => ByteString -> Maybe (r, ByteString) +floating10 s = floating' (Proxy :: Proxy 10) s >>= \(f, s') -> + let (e, s'') = exponential (Proxy :: Proxy r) s' + in Just (setExpPart e f, s'') +{-# INLINABLE floating10 #-} + +-- | convert bytestring into unsigned floating using radix. +-- +-- this function can parse +-- +-- * oct/hexa-decimal (0o,0O,0x,0X) (optional) +-- * floating(0.1, 12224.3543) +-- * exponential (e1, E+2, e-123) (10-radixed only, optional) +-- +-- >>> floating "12.4" :: Maybe (Double, ByteString) +-- Just (12.4,"") +-- >>> floating "1.23e12" :: Maybe (Double, ByteString) +-- Just (1.23e12,"") +-- >>> floating "0o0.4" :: Maybe (Double, ByteString) +-- Just (0.5,"") +-- >>> floating "0x3f.12" :: Maybe (Double, ByteString) +-- Just (63.0703125,"") +floating :: EffectiveDigit r => ByteString -> Maybe (r, ByteString) +floating s0 + | S.null s0 = Nothing + | unsafeHead s0 == zero = base $ unsafeTail s0 + | otherwise = floating10 s0 + where + zero = 48 + isX w = w == 120 || w == 88 + isO w = w == 111 || w == 79 + + base s1 + | S.null s1 = Just (0, "") + | isX (unsafeHead s1) = floating' (Proxy :: Proxy 16) (unsafeTail s1) + | isO (unsafeHead s1) = floating' (Proxy :: Proxy 8) (unsafeTail s1) + | otherwise = floating10 s0 +{-# INLINABLE floating #-} + +-- | @ +-- double = floating +-- @ +double :: ByteString -> Maybe (Double, ByteString) +double = floating + +-- | convert unsigned parser to signed parser. +-- +-- this function can parse +-- +-- * sign (+, -) (optional) +-- +-- >>> signed double "12.4" +-- Just (12.4,"") +-- >>> signed double "-3.21e3" +-- Just (-3210.0,"") +-- >>> signed double "+0x1f.4" +-- Just (31.25,"") +signed :: Num r => (ByteString -> Maybe (r, ByteString)) -> ByteString -> Maybe (r, ByteString) +signed f s + | S.null s = Nothing + | unsafeHead s == minus = first negate <$> f (unsafeTail s) + | unsafeHead s == plus = f (unsafeTail s) + | otherwise = f s diff --git a/tests/doctest.hs b/tests/doctest.hs new file mode 100644 --- /dev/null +++ b/tests/doctest.hs @@ -0,0 +1,2 @@ +import Test.DocTest +main = doctest ["-isrc", "src/Data/ByteString/Read.hs"] diff --git a/tests/tasty.hs b/tests/tasty.hs new file mode 100644 --- /dev/null +++ b/tests/tasty.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE OverloadedStrings #-} +import Numeric +import Control.Monad +import qualified Data.ByteString.Char8 as S +import Data.ByteString.Read +import Test.Tasty +import Test.Tasty.QuickCheck + +(=~~) :: Double -> Double -> Bool +(=~~) a b = a == b || abs (a - b) <= max (abs a) (abs b) * 1e20 + +-- Word + +newtype Word8 = Word8 String + deriving Show + +instance Arbitrary Word8 where + arbitrary = do + i <- choose (1, 50) + n <- replicateM i $ choose ('0', '7') + return $ Word8 $ "0o" ++ n + +newtype Word10 = Word10 String + deriving Show + +instance Arbitrary Word10 where + arbitrary = do + i <- choose (1, 50) + n <- replicateM i $ choose ('0', '9') + return $ Word10 n + +newtype Word16 = Word16 String + deriving Show + +instance Arbitrary Word16 where + arbitrary = do + i <- choose (1, 50) + n <- replicateM i $ oneof [choose ('0', '9'), choose ('a', 'f'), choose ('A', 'F')] + return $ Word16 $ "0x" ++ n + +-- Int +newtype Int8 = Int8 String + deriving Show + +instance Arbitrary Int8 where + arbitrary = do + sign <- oneof $ map return ["", "-"] + Word8 w <- arbitrary + return . Int8 $ sign ++ w + +newtype Int10 = Int10 String + deriving Show + +instance Arbitrary Int10 where + arbitrary = do + sign <- oneof $ map return ["", "-"] + Word10 w <- arbitrary + return . Int10 $ sign ++ w + +newtype Int16 = Int16 String + deriving Show + +instance Arbitrary Int16 where + arbitrary = do + sign <- oneof $ map return ["", "-"] + Word16 w <- arbitrary + return . Int16 $ sign ++ w + +-- Float +newtype Float10 = Float10 String + deriving Show + +instance Arbitrary Float10 where + arbitrary = do + Int10 q <- arbitrary + Word10 r <- arbitrary + return . Float10 $ q ++ '.': r + +newtype SmallFloat10 = SmallFloat10 String + deriving Show + +instance Arbitrary SmallFloat10 where + arbitrary = do + sign <- oneof $ map return ["", "-"] + i <- choose (0, 100) + Word10 r <- arbitrary + return . SmallFloat10 $ sign ++ "0." ++ replicate i '0' ++ r + +newtype Float10Exp = Float10Exp String + deriving Show + +instance Arbitrary Float10Exp where + arbitrary = do + Float10 f <- arbitrary + c <- oneof $ map return "eE" + s <- oneof $ map return ["", "+", "-"] + e <- choose (0, 10000 :: Int) + return . Float10Exp $ f ++ c: s ++ show e + +main :: IO () +main = defaultMain $ testGroup "read . show == id" + [ testProperty "showEFloat" $ \d -> + let Just (d', "") = signed floating . S.pack $ showEFloat Nothing d "" + in (d :: Double) =~~ d' + + , testProperty "showFFloat" $ \d -> + let Just (d', "") = signed floating . S.pack $ showFFloat Nothing d "" + in (d :: Double) =~~ d' + + , testProperty "showGFloat" $ \d -> + let Just (d', "") = signed floating . S.pack $ showGFloat Nothing d "" + in (d :: Double) =~~ d' + + , testProperty "showHex" $ \i -> + let Just (i', "") = signed floating . (S.append "0x") . S.pack $ showHex (abs i) "" + in fromIntegral (abs i :: Int) =~~ i' + + , testProperty "showOct" $ \i -> + let Just (i', "") = signed floating . (S.append "0o") . S.pack $ showOct (abs i) "" + in fromIntegral (abs i :: Int) =~~ i' + + , testProperty "Word8" $ \(Word8 d) -> + let Just (d', "") = signed floating (S.pack d) + in d' =~~ (read d :: Double) + + , testProperty "Word10" $ \(Word10 d) -> + let Just (d', "") = signed floating (S.pack d) + in d' =~~ (read d :: Double) + + , testProperty "Word16" $ \(Word16 d) -> + let Just (d', "") = signed floating (S.pack d) + in d' =~~ (read d :: Double) + + , testProperty "Int8" $ \(Int8 d) -> + let Just (d', "") = signed floating (S.pack d) + in d' =~~ (read d :: Double) + + , testProperty "Int10" $ \(Int10 d) -> + let Just (d', "") = signed floating (S.pack d) + in d' =~~ (read d :: Double) + + , testProperty "Int16" $ \(Int16 d) -> + let Just (d', "") = signed floating (S.pack d) + in d' =~~ (read d :: Double) + + , testProperty "Float10" $ \(Float10 d) -> + let Just (d', "") = signed floating (S.pack d) + in d' =~~ (read d :: Double) + + , testProperty "SmallFloat10" $ \(SmallFloat10 d) -> + let Just (d', "") = signed floating (S.pack d) + in d' =~~ (read d :: Double) + + , testProperty "Float10Exp" $ \(Float10Exp d) -> + let Just (d', "") = signed floating (S.pack d) + in d' =~~ (read d :: Double) + ]