mysql-simple 0.4.5 → 0.4.6
raw patch · 5 files changed
+297/−5 lines, 5 filesdep +vector
Dependencies added: vector
Files
- ChangeLog.md +4/−0
- Database/MySQL/Internal/Blaze.hs +275/−0
- Database/MySQL/Simple/Param.hs +2/−1
- mysql-simple.cabal +15/−3
- stack.yaml +1/−1
ChangeLog.md view
@@ -1,3 +1,7 @@+## 0.4.6++* Support GHC-9 via blaze-textual shim (https://github.com/paul-rouse/mysql-simple/pull/51).+ ## 0.4.5 * Add Semigroup instance for Query
+ Database/MySQL/Internal/Blaze.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns, CPP, MagicHash, OverloadedStrings, UnboxedTuples #-}++-- | This module is designed to provide a shim for @blaze-textual@.+-- @blaze-textual@ does not support GHC 9. A PR has been opened to add that+-- support for GHC 9 here: https://github.com/bos/blaze-textual/pull/14+--+-- When GHC 9 support is merged in, we can delete the CPP in this and+-- re-export the blaze functions directly, which is what we do for older+-- versions of base.+module Database.MySQL.Internal.Blaze+ ( integral+ , double+ , float+ ) where++#if MIN_VERSION_base(4,15,0)++#define PAIR(a,b) (# a,b #)++import Blaze.ByteString.Builder (Builder, fromByteString)+import Blaze.ByteString.Builder.Char8 (fromChar)+import Data.ByteString.Char8 ()+import Data.Monoid (mappend, mconcat, mempty)+import qualified Data.Vector as V++import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Char8+import Data.ByteString.Char8 ()+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Monoid (mappend, mempty)+import Data.Word (Word, Word8, Word16, Word32, Word64)+import GHC.Base (quotInt, remInt)+import GHC.Num (quotRemInteger)+-- import GHC.Types (Int(..))++#if defined(INTEGER_GMP)+import GHC.Integer.GMP.Internals+#elif defined(INTEGER_SIMPLE)+import GHC.Integer.Simple.Internals+#endif++minus :: Builder+minus = fromWord8 45+data TInt = TInt !Integer !Int+putH :: [Integer] -> Builder+putH (n:ns) = case n `quotRemInteger` maxInt of+ PAIR(x,y)+ | q > 0 -> int q `mappend` pblock r `mappend` putB ns+ | otherwise -> int r `mappend` putB ns+ where q = fromInteger x+ r = fromInteger y+putH _ = error "putH: the impossible happened"+int :: Int -> Builder+int = integral+{-# INLINE int #-}+fstT :: TInt -> Integer+fstT (TInt a _) = a+maxInt :: Integer+maxDigits :: Int+TInt maxInt maxDigits =+ until ((>mi) . (*10) . fstT) (\(TInt n d) -> TInt (n*10) (d+1)) (TInt 10 1)+ where mi = fromIntegral (maxBound :: Int)+integral :: (Integral a, Show a) => a -> Builder+{-# RULES "integral/Int" integral = bounded :: Int -> Builder #-}+{-# RULES "integral/Int8" integral = bounded :: Int8 -> Builder #-}+{-# RULES "integral/Int16" integral = bounded :: Int16 -> Builder #-}+{-# RULES "integral/Int32" integral = bounded :: Int32 -> Builder #-}+{-# RULES "integral/Int64" integral = bounded :: Int64 -> Builder #-}+{-# RULES "integral/Word" integral = nonNegative :: Word -> Builder #-}+{-# RULES "integral/Word8" integral = nonNegative :: Word8 -> Builder #-}+{-# RULES "integral/Word16" integral = nonNegative :: Word16 -> Builder #-}+{-# RULES "integral/Word32" integral = nonNegative :: Word32 -> Builder #-}+{-# RULES "integral/Word64" integral = nonNegative :: Word64 -> Builder #-}+{-# RULES "integral/Integer" integral = integer :: Integer -> Builder #-}++-- This definition of the function is here PURELY to be used by ghci+-- and those rare cases where GHC is being invoked without+-- optimization, as otherwise the rewrite rules above should fire. The+-- test for "-0" catches an overflow if we render minBound.+integral i+ | i >= 0 = nonNegative i+ | toByteString b == "-0" = fromString (show i)+ | otherwise = b+ where b = minus `mappend` nonNegative (-i)++{-# NOINLINE integral #-}++pblock :: Int -> Builder+pblock = go maxDigits+ where+ go !d !n+ | d == 1 = digit n+ | otherwise = go (d-1) q `mappend` digit r+ where q = n `quotInt` 10+ r = n `remInt` 10++putB :: [Integer] -> Builder+putB (n:ns) = case n `quotRemInteger` maxInt of+ PAIR(x,y) -> pblock q `mappend` pblock r `mappend` putB ns+ where q = fromInteger x+ r = fromInteger y+putB _ = mempty++bounded :: (Bounded a, Integral a) => a -> Builder+{-# SPECIALIZE bounded :: Int -> Builder #-}+{-# SPECIALIZE bounded :: Int8 -> Builder #-}+{-# SPECIALIZE bounded :: Int16 -> Builder #-}+{-# SPECIALIZE bounded :: Int32 -> Builder #-}+{-# SPECIALIZE bounded :: Int64 -> Builder #-}+bounded i+ | i >= 0 = nonNegative i+ | i > minBound = minus `mappend` nonNegative (-i)+ | otherwise = minus `mappend`+ nonNegative (negate (k `quot` 10)) `mappend`+ digit (negate (k `rem` 10))+ where k = minBound `asTypeOf` i++nonNegative :: Integral a => a -> Builder+{-# SPECIALIZE nonNegative :: Int -> Builder #-}+{-# SPECIALIZE nonNegative :: Int8 -> Builder #-}+{-# SPECIALIZE nonNegative :: Int16 -> Builder #-}+{-# SPECIALIZE nonNegative :: Int32 -> Builder #-}+{-# SPECIALIZE nonNegative :: Int64 -> Builder #-}+{-# SPECIALIZE nonNegative :: Word -> Builder #-}+{-# SPECIALIZE nonNegative :: Word8 -> Builder #-}+{-# SPECIALIZE nonNegative :: Word16 -> Builder #-}+{-# SPECIALIZE nonNegative :: Word32 -> Builder #-}+{-# SPECIALIZE nonNegative :: Word64 -> Builder #-}+nonNegative = go+ where+ go n | n < 10 = digit n+ | otherwise = go (n `quot` 10) `mappend` digit (n `rem` 10)++digit :: Integral a => a -> Builder+digit n = fromWord8 $! fromIntegral n + 48+{-# INLINE digit #-}++integer :: Integer -> Builder+#if defined(INTEGER_GMP)+integer (S# i#) = int (I# i#)+#endif+integer i+ | i < 0 = minus `mappend` go (-i)+ | otherwise = go i+ where+ go n | n < maxInt = int (fromInteger n)+ | otherwise = putH (splitf (maxInt * maxInt) n)++ splitf p n+ | p > n = [n]+ | otherwise = splith p (splitf (p*p) n)++ splith p (n:ns) = case n `quotRemInteger` p of+ PAIR(q,r) | q > 0 -> q : r : splitb p ns+ | otherwise -> r : splitb p ns+ splith _ _ = error "splith: the impossible happened."++ splitb p (n:ns) = case n `quotRemInteger` p of+ PAIR(q,r) -> q : r : splitb p ns+ splitb _ _ = []+++-- The code below is originally from GHC.Float, but has been optimised+-- in quite a few ways.++data T = T [Int] {-# UNPACK #-} !Int++float :: Float -> Builder+float = double . realToFrac++double :: Double -> Builder+double f+ | isInfinite f = fromByteString $+ if f > 0 then "Infinity" else "-Infinity"+ | f < 0 || isNegativeZero f = minus `mappend` goGeneric (floatToDigits (-f))+ | f >= 0 = goGeneric (floatToDigits f)+ | otherwise = fromByteString "NaN"+ where+ goGeneric p@(T _ e)+ | e < 0 || e > 7 = goExponent p+ | otherwise = goFixed p+ goExponent (T is e) =+ case is of+ [] -> error "putFormattedFloat"+ [0] -> fromByteString "0.0e0"+ [d] -> digit d `mappend` fromByteString ".0e" `mappend` integral (e-1)+ (d:ds) -> digit d `mappend` fromChar '.' `mappend` digits ds `mappend`+ fromChar 'e' `mappend` integral (e-1)+ goFixed (T is e)+ | e <= 0 = fromChar '0' `mappend` fromChar '.' `mappend`+ mconcat (replicate (-e) (fromChar '0')) `mappend`+ digits is+ | otherwise = let g 0 rs = fromChar '.' `mappend` mk0 rs+ g n [] = fromChar '0' `mappend` g (n-1) []+ g n (r:rs) = digit r `mappend` g (n-1) rs+ in g e is+ mk0 [] = fromChar '0'+ mk0 rs = digits rs++digits :: [Int] -> Builder+digits (d:ds) = digit d `mappend` digits ds+digits _ = mempty+{-# INLINE digits #-}++floatToDigits :: Double -> T+floatToDigits 0 = T [0] 0+floatToDigits x = T (reverse rds) k+ where+ (f0, e0) = decodeFloat x+ (minExp0, _) = floatRange (undefined::Double)+ p = floatDigits x+ b = floatRadix x+ minExp = minExp0 - p -- the real minimum exponent+ -- Haskell requires that f be adjusted so denormalized numbers+ -- will have an impossibly low exponent. Adjust for this.+ (# f, e #) =+ let n = minExp - e0 in+ if n > 0 then (# f0 `div` (b^n), e0+n #) else (# f0, e0 #)+ (# r, s, mUp, mDn #) =+ if e >= 0+ then let be = b^ e+ in if f == b^(p-1)+ then (# f*be*b*2, 2*b, be*b, b #)+ else (# f*be*2, 2, be, be #)+ else if e > minExp && f == b^(p-1)+ then (# f*b*2, b^(-e+1)*2, b, 1 #)+ else (# f*2, b^(-e)*2, 1, 1 #)+ k = fixup k0+ where+ k0 | b == 2 = (p - 1 + e0) * 3 `div` 10+ -- logBase 10 2 is slightly bigger than 3/10 so the following+ -- will err on the low side. Ignoring the fraction will make+ -- it err even more. Haskell promises that p-1 <= logBase b f+ -- < p.+ | otherwise = ceiling ((log (fromInteger (f+1) :: Double) ++ fromIntegral e * log (fromInteger b)) / log 10)+ fixup n+ | n >= 0 = if r + mUp <= exp10 n * s then n else fixup (n+1)+ | otherwise = if exp10 (-n) * (r + mUp) <= s then n else fixup (n+1)++ gen ds !rn !sN !mUpN !mDnN =+ let (dn0, rn') = (rn * 10) `divMod` sN+ mUpN' = mUpN * 10+ mDnN' = mDnN * 10+ !dn = fromInteger dn0+ !dn' = dn + 1+ in case (# rn' < mDnN', rn' + mUpN' > sN #) of+ (# True, False #) -> dn : ds+ (# False, True #) -> dn' : ds+ (# True, True #) -> if rn' * 2 < sN then dn : ds else dn' : ds+ (# False, False #) -> gen (dn:ds) rn' sN mUpN' mDnN'++ rds | k >= 0 = gen [] r (s * exp10 k) mUp mDn+ | otherwise = gen [] (r * bk) s (mUp * bk) (mDn * bk)+ where bk = exp10 (-k)++exp10 :: Int -> Integer+exp10 n+ | n >= 0 && n < maxExpt = V.unsafeIndex expts n+ | otherwise = 10 ^ n+ where expts = V.generate maxExpt (10^)+ {-# NOINLINE expts #-}+ maxExpt = 17+{-# INLINE exp10 #-}+++++#else++import Blaze.Text (integral, double, float)++#endif+
Database/MySQL/Simple/Param.hs view
@@ -21,7 +21,6 @@ import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString, toByteString) import Blaze.ByteString.Builder.Char8 (fromChar)-import Blaze.Text (integral, double, float) import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Base16.Lazy as L16@@ -43,6 +42,8 @@ import qualified Data.Text as ST import qualified Data.Text.Encoding as ST import qualified Data.Text.Lazy as LT++import Database.MySQL.Internal.Blaze (integral, double, float) #if MIN_VERSION_time(1,5,0) import Data.Time.Format (defaultTimeLocale)
mysql-simple.cabal view
@@ -1,5 +1,5 @@ name: mysql-simple-version: 0.4.5+version: 0.4.6 homepage: https://github.com/paul-rouse/mysql-simple bug-reports: https://github.com/paul-rouse/mysql-simple/issues synopsis: A mid-level MySQL client library.@@ -21,7 +21,7 @@ copyright: 2011 MailRank, Inc. category: Database build-type: Simple-cabal-version: >= 1.8+cabal-version: >= 1.10 extra-source-files: ChangeLog.md README.markdown@@ -40,13 +40,14 @@ Database.MySQL.Simple.QueryResults Database.MySQL.Simple.Result Database.MySQL.Simple.Types+ other-modules:+ Database.MySQL.Internal.Blaze build-depends: attoparsec >= 0.10.0.0, base < 5, base16-bytestring, blaze-builder,- blaze-textual, bytestring >= 0.9, containers, mysql >= 0.1.1.1,@@ -58,6 +59,15 @@ build-depends: semigroups >= 0.11 && < 0.19 + -- hack to support GHC 9 for blaze-textual. see Database.MySQL.Internal.Blaze+ -- for reasoning+ if !impl(ghc >= 9.0)+ build-depends:+ blaze-textual+ else+ build-depends:+ vector+ ghc-options: -Wall -fwarn-tabs if impl(ghc >= 7.10) ghc-options: -fno-warn-unused-imports@@ -65,12 +75,14 @@ ghc-prof-options: -auto-all ghc-options: -Werror cpp-options: -DASSERTS+ default-language: Haskell2010 test-suite test type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test ghc-options: -Wall+ default-language: Haskell2010 build-depends: base >= 4 && < 5 , blaze-builder , hspec
stack.yaml view
@@ -4,4 +4,4 @@ packages: - '.' extra-deps: []-resolver: lts-6.23+resolver: lts-16.27