Commits

Bryan O'Sullivan committed 1db298b

Get rid of poxy NFData from everywhere.

Comments (0)

Files changed (6)

Database/MySQL/Simple.hs

-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE BangPatterns, DeriveDataTypeable #-}
 
 -- |
 -- Module:      Database.MySQL.Simple
 
 import Blaze.ByteString.Builder (fromByteString, toByteString)
 import Control.Applicative ((<$>), pure)
-import Control.DeepSeq (NFData(..))
 import Control.Exception (Exception, throw)
 import Control.Monad.Fix (fix)
 import Data.ByteString (ByteString)
     then error "execute: executed a select!"
     else Base.affectedRows conn
   
-query :: (QueryParams q, QueryResults r, NFData r)
+query :: (QueryParams q, QueryResults r)
          => Connection -> Query -> q -> IO [r]
 query conn template qs = do
   Base.query conn =<< formatQuery conn template qs
   finishQuery conn
   
-query_ :: (QueryResults r, NFData r) => Connection -> Query -> IO [r]
+query_ :: (QueryResults r) => Connection -> Query -> IO [r]
 query_ conn (Query q) = do
   Base.query conn q
   finishQuery conn
 
-finishQuery :: (QueryResults r, NFData r) => Connection -> IO [r]
+finishQuery :: (QueryResults r) => Connection -> IO [r]
 finishQuery conn = do
   r <- Base.storeResult conn
   ncols <- Base.fieldCount (Right r)
         row <- Base.fetchRow r
         case row of
           [] -> return (reverse acc)
-          _  -> let c = convertResults fs row
-                in rnf c `seq` loop (c:acc)
+          _  -> let !c = convertResults fs row
+                in loop (c:acc)
 
 fmtError :: String -> Query -> [Action] -> a
 fmtError msg q xs = throw FormatError {

Database/MySQL/Simple/Orphans.hs

-{-# LANGUAGE BangPatterns #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
--- |
--- Module:      Database.MySQL.Orphans
--- Copyright:   (c) 2011 MailRank, Inc.
--- License:     BSD3
--- Maintainer:  Bryan O'Sullivan <bos@mailrank.com>
--- Stability:   experimental
--- Portability: portable
---
--- Orphan instances of frequently used typeclasses for types that
--- really should have them.
-
-module Database.MySQL.Simple.Orphans () where
-
-import Control.DeepSeq (NFData(..))
-import Data.Time.Calendar (Day(..))
-import Data.Time.Clock (UTCTime(..))
-import Data.Time.LocalTime (TimeOfDay(..))
-import qualified Data.ByteString.Internal as SB
-import qualified Data.ByteString.Lazy.Internal as LB
-
-instance NFData SB.ByteString where
-    rnf (SB.PS _ _ _) = ()
-    {-# INLINE rnf #-}
-
-instance NFData LB.ByteString where
-    rnf (LB.Chunk (SB.PS _ _ _) cs) = rnf cs
-    rnf LB.Empty = ()
-
-instance NFData Day where
-    rnf (ModifiedJulianDay !_) = ()
-    {-# INLINE rnf #-}
-
-instance NFData TimeOfDay where
-    rnf (TimeOfDay !_ !_ !_) = ()
-    {-# INLINE rnf #-}
-
-instance NFData UTCTime where
-    rnf (UTCTime !_ !_) = ()
-    {-# INLINE rnf #-}
-
-instance (NFData a, NFData b, NFData c, NFData d, NFData e, NFData f,
-          NFData g, NFData h, NFData i, NFData j) =>
-    NFData (a,b,c,d,e,f,g,h,i,j)
-  where
-    rnf (a,b,c,d,e,f,g,h,i,j) =
-      rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e `seq`
-      rnf f `seq` rnf g `seq` rnf h `seq` rnf i `seq` rnf j
-    {-# INLINE rnf #-}

Database/MySQL/Simple/QueryResults.hs

+{-# LANGUAGE BangPatterns #-}
+
 -- |
 -- Module:      Database.MySQL.Simpe.QueryResults
 -- Copyright:   (c) 2011 MailRank, Inc.
 module Database.MySQL.Simple.QueryResults
     (
       QueryResults(..)
+    , convertError
     ) where
 
 import Control.Exception (throw)
 import Database.MySQL.Simple.Types (Only(..))
 
 -- | A collection type that can be converted from a list of strings.
+--
+-- Instances should use the 'convert' method of the 'Result' class
+-- to perform conversion of each element of the collection.
+--
+-- This example instance demonstrates how to convert a two-column row
+-- into a Haskell pair. Each field in the metadata is paired up with
+-- each value from the row, and the two are passed to 'convert'.
+--
+-- @
+-- instance ('Result' a, 'Result' b) => 'QueryResults' (a,b) where
+--     'convertResults' [fa,fb] [va,vb] = (a,b)
+--         where !a = 'convert' fa va
+--               !b = 'convert' fb vb
+--     'convertResults' fs vs  = 'convertError' fs vs
+-- @
+--
+-- Notice that this instance evaluates each element to WHNF before
+-- constructing the pair. By doing this, we guarantee two important
+-- properties:
+--
+-- * Keep resource usage under control by preventing the construction
+--   of potentially long-lived thunks.
+--
+-- * Ensure that any 'ResultError' that might arise is thrown
+--   immediately, rather than some place later in application code
+--   that cannot handle it.
 class QueryResults a where
     convertResults :: [Field] -> [Maybe ByteString] -> a
     -- ^ Convert values from a row into a Haskell collection.
     --
-    -- This function will throw an exception if conversion of any
-    -- element of the collection fails.
+    -- This function will throw a 'ResultError' if conversion of the
+    -- collection fails.
 
 instance (Result a) => QueryResults (Only a) where
-    convertResults [fa] [va] = Only (convert fa va)
-    convertResults fs vs  = convError fs vs
+    convertResults [fa] [va] = Only a
+        where !a = convert fa va
+    convertResults fs vs  = convertError fs vs
 
 instance (Result a, Result b) => QueryResults (a,b) where
-    convertResults [fa,fb] [va,vb] = (convert fa va, convert fb vb)
-    convertResults fs vs  = convError fs vs
+    convertResults [fa,fb] [va,vb] = (a,b)
+        where !a = convert fa va; !b = convert fb vb
+    convertResults fs vs  = convertError fs vs
 
 instance (Result a, Result b, Result c) => QueryResults (a,b,c) where
-    convertResults [fa,fb,fc] [va,vb,vc] =
-        (convert fa va, convert fb vb, convert fc vc)
-    convertResults fs vs  = convError fs vs
+    convertResults [fa,fb,fc] [va,vb,vc] = (a,b,c)
+        where !a = convert fa va; !b = convert fb vb; !c = convert fc vc
+    convertResults fs vs  = convertError fs vs
 
 instance (Result a, Result b, Result c, Result d) =>
     QueryResults (a,b,c,d) where
-    convertResults [fa,fb,fc,fd] [va,vb,vc,vd] =
-        (convert fa va, convert fb vb, convert fc vc, convert fd vd)
-    convertResults fs vs  = convError fs vs
+    convertResults [fa,fb,fc,fd] [va,vb,vc,vd] = (a,b,c,d)
+        where !a = convert fa va; !b = convert fb vb; !c = convert fc vc
+              !d = convert fd vd
+    convertResults fs vs  = convertError fs vs
 
 instance (Result a, Result b, Result c, Result d, Result e) =>
     QueryResults (a,b,c,d,e) where
-    convertResults [fa,fb,fc,fd,fe] [va,vb,vc,vd,ve] =
-        (convert fa va, convert fb vb, convert fc vc, convert fd vd,
-         convert fe ve)
-    convertResults fs vs  = convError fs vs
+    convertResults [fa,fb,fc,fd,fe] [va,vb,vc,vd,ve] = (a,b,c,d,e)
+        where !a = convert fa va; !b = convert fb vb; !c = convert fc vc
+              !d = convert fd vd; !e = convert fe ve
+    convertResults fs vs  = convertError fs vs
 
 instance (Result a, Result b, Result c, Result d, Result e, Result f) =>
     QueryResults (a,b,c,d,e,f) where
-    convertResults [fa,fb,fc,fd,fe,ff] [va,vb,vc,vd,ve,vf] =
-        (convert fa va, convert fb vb, convert fc vc, convert fd vd,
-         convert fe ve, convert ff vf)
-    convertResults fs vs  = convError fs vs
+    convertResults [fa,fb,fc,fd,fe,ff] [va,vb,vc,vd,ve,vf] = (a,b,c,d,e,f)
+        where !a = convert fa va; !b = convert fb vb; !c = convert fc vc
+              !d = convert fd vd; !e = convert fe ve; !f = convert ff vf
+    convertResults fs vs  = convertError fs vs
 
 instance (Result a, Result b, Result c, Result d, Result e, Result f,
           Result g) =>
     QueryResults (a,b,c,d,e,f,g) where
     convertResults [fa,fb,fc,fd,fe,ff,fg] [va,vb,vc,vd,ve,vf,vg] =
-        (convert fa va, convert fb vb, convert fc vc, convert fd vd,
-         convert fe ve, convert ff vf, convert fg vg)
-    convertResults fs vs  = convError fs vs
+        (a,b,c,d,e,f,g)
+        where !a = convert fa va; !b = convert fb vb; !c = convert fc vc
+              !d = convert fd vd; !e = convert fe ve; !f = convert ff vf
+              !g = convert fg vg
+    convertResults fs vs  = convertError fs vs
 
 instance (Result a, Result b, Result c, Result d, Result e, Result f,
           Result g, Result h) =>
     QueryResults (a,b,c,d,e,f,g,h) where
     convertResults [fa,fb,fc,fd,fe,ff,fg,fh] [va,vb,vc,vd,ve,vf,vg,vh] =
-        (convert fa va, convert fb vb, convert fc vc, convert fd vd,
-         convert fe ve, convert ff vf, convert fg vg, convert fh vh)
-    convertResults fs vs  = convError fs vs
+        (a,b,c,d,e,f,g,h)
+        where !a = convert fa va; !b = convert fb vb; !c = convert fc vc
+              !d = convert fd vd; !e = convert fe ve; !f = convert ff vf
+              !g = convert fg vg; !h = convert fh vh
+    convertResults fs vs  = convertError fs vs
 
 instance (Result a, Result b, Result c, Result d, Result e, Result f,
           Result g, Result h, Result i) =>
     QueryResults (a,b,c,d,e,f,g,h,i) where
     convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi] [va,vb,vc,vd,ve,vf,vg,vh,vi] =
-        (convert fa va, convert fb vb, convert fc vc, convert fd vd,
-         convert fe ve, convert ff vf, convert fg vg, convert fh vh,
-         convert fi vi)
-    convertResults fs vs  = convError fs vs
+        (a,b,c,d,e,f,g,h,i)
+        where !a = convert fa va; !b = convert fb vb; !c = convert fc vc
+              !d = convert fd vd; !e = convert fe ve; !f = convert ff vf
+              !g = convert fg vg; !h = convert fh vh; !i = convert fi vi
+    convertResults fs vs  = convertError fs vs
 
 instance (Result a, Result b, Result c, Result d, Result e, Result f,
           Result g, Result h, Result i, Result j) =>
     QueryResults (a,b,c,d,e,f,g,h,i,j) where
     convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi,fj]
                    [va,vb,vc,vd,ve,vf,vg,vh,vi,vj] =
-        (convert fa va, convert fb vb, convert fc vc, convert fd vd,
-         convert fe ve, convert ff vf, convert fg vg, convert fh vh,
-         convert fi vi, convert fj vj)
-    convertResults fs vs  = convError fs vs
+        (a,b,c,d,e,f,g,h,i,j)
+        where !a = convert fa va; !b = convert fb vb; !c = convert fc vc
+              !d = convert fd vd; !e = convert fe ve; !f = convert ff vf
+              !g = convert fg vg; !h = convert fh vh; !i = convert fi vi
+              !j = convert fj vj
+    convertResults fs vs  = convertError fs vs
 
-convError :: [Field] -> [Maybe ByteString] -> a
-convError fs vs = throw $ ConversionFailed
+-- | Throw a 'ConversionFailed' exception, indicating a mismatch
+-- between the number of columns in the 'Field' and the number in the
+-- row.  (This should never happen.)
+convertError :: [Field] -> [Maybe ByteString] -> a
+convertError fs vs = throw $ ConversionFailed
                   (show (length fs) ++ " columns left in result")
                   (show (length vs) ++ " values left in row")
                   "mismatch between number of columns to convert"

Database/MySQL/Simple/Result.hs

 import Data.Typeable (TypeRep, Typeable, typeOf)
 import Data.Word (Word, Word8, Word16, Word32, Word64)
 import Database.MySQL.Base.Types (Field(..), Type(..))
-import Database.MySQL.Simple.Orphans ()
 import System.Locale (defaultTimeLocale)
 import qualified Data.ByteString as SB
 import qualified Data.ByteString.Char8 as B8
                                     , errHaskellType :: String
                                     , errMessage :: String }
                  -- ^ The SQL value could not be parsed, or could not
-                 -- be represented as a valid Haskell value.
+                 -- be represented as a valid Haskell value, or an
+                 -- unexpected low-level error occurred (e.g. mismatch
+                 -- between metadata and actual data in a row).
                    deriving (Eq, Show, Typeable)
 
 instance Exception ResultError

Database/MySQL/Simple/Types.hs

 
 import Blaze.ByteString.Builder
 import Control.Arrow
-import Control.DeepSeq (NFData)
 import Data.ByteString (ByteString)
 import Data.String (IsString(..))
 import Data.Typeable (Typeable)
 import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8
 
+-- | A placeholder for the SQL @NULL@ value.
 data Null = Null
           deriving (Read, Show, Typeable)
 
 --
 -- @query \"select x from scores where x > ?\" ('Only' (42::Int))@
 newtype Only a = Only a
-    deriving (Eq, Ord, Read, Show, NFData, Typeable, Functor)
+    deriving (Eq, Ord, Read, Show, Typeable, Functor)

mysql-simple.cabal

     Database.MySQL.Simple.Result
     Database.MySQL.Simple.Types
 
-  other-modules:
-    Database.MySQL.Simple.Orphans
-
   build-depends:
     attoparsec >= 0.8.5.3,
     base < 5,
     blaze-builder,
     blaze-textual,
     bytestring >= 0.9,
-    deepseq,
     mysql,
     old-locale,
     text >= 0.11.0.2,