diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Database/MySQL/Internal/Blaze.hs b/Database/MySQL/Internal/Blaze.hs new file mode 100644 --- /dev/null +++ b/Database/MySQL/Internal/Blaze.hs @@ -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 + diff --git a/Database/MySQL/Simple/Param.hs b/Database/MySQL/Simple/Param.hs --- a/Database/MySQL/Simple/Param.hs +++ b/Database/MySQL/Simple/Param.hs @@ -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) diff --git a/mysql-simple.cabal b/mysql-simple.cabal --- a/mysql-simple.cabal +++ b/mysql-simple.cabal @@ -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 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -4,4 +4,4 @@ packages: - '.' extra-deps: [] -resolver: lts-6.23 +resolver: lts-16.27