Generation of tuple instances for FromRow with huge arities using TH macro

postgresql-simple.cabal

@@ -46,6 +46,7 @@ Library
      Database.PostgreSQL.Simple.Internal
 
   Other-modules:
+     Database.PostgreSQL.Simple.FromRow.Boilerplate
      Database.PostgreSQL.Simple.Compat
      Database.PostgreSQL.Simple.HStore.Implementation
      Database.PostgreSQL.Simple.Time.Implementation

src/Database/PostgreSQL/Simple/FromRow.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE RecordWildCards, FlexibleInstances #-}
+{-# LANGUAGE RecordWildCards, FlexibleInstances, TemplateHaskell #-}
 
 ------------------------------------------------------------------------------
 -- |
@@ -28,7 +28,7 @@ module Database.PostgreSQL.Simple.FromRow
 
 import           Prelude hiding (null)
 import           Control.Applicative (Applicative(..), (<$>), (<|>), (*>))
-import           Control.Monad (replicateM, replicateM_)
+import           Control.Monad 
 import           Control.Monad.Trans.State.Strict
 import           Control.Monad.Trans.Reader
 import           Control.Monad.Trans.Class
@@ -44,6 +44,7 @@ import           Database.PostgreSQL.Simple.FromField
 import           Database.PostgreSQL.Simple.Ok
 import           Database.PostgreSQL.Simple.Types ((:.)(..), Null)
 import           Database.PostgreSQL.Simple.TypeInfo
+import qualified Database.PostgreSQL.Simple.FromRow.Boilerplate as Boilerplate
 
 -- | A collection type that can be converted from a sequence of fields.
 -- Instances are provided for tuples up to 10 elements and lists of any length.
@@ -133,96 +134,52 @@ instance (FromField a) => FromRow (Maybe (Only a)) where
     fromRow =  (null *> pure Nothing)
            <|> (Just <$> fromRow)
 
-instance (FromField a, FromField b) => FromRow (a,b) where
-    fromRow = (,) <$> field <*> field
-
 instance (FromField a, FromField b) => FromRow (Maybe (a,b)) where
     fromRow =  (null *> null *> pure Nothing)
            <|> (Just <$> fromRow)
 
-instance (FromField a, FromField b, FromField c) => FromRow (a,b,c) where
-    fromRow = (,,) <$> field <*> field <*> field
-
 instance (FromField a, FromField b, FromField c) => FromRow (Maybe (a,b,c)) where
     fromRow =  (null *> null *> null *> pure Nothing)
            <|> (Just <$> fromRow)
 
-instance (FromField a, FromField b, FromField c, FromField d) =>
-    FromRow (a,b,c,d) where
-    fromRow = (,,,) <$> field <*> field <*> field <*> field
-
 instance (FromField a, FromField b, FromField c, FromField d) =>
     FromRow (Maybe (a,b,c,d)) where
     fromRow =  (null *> null *> null *> null *> pure Nothing)
            <|> (Just <$> fromRow)
 
-instance (FromField a, FromField b, FromField c, FromField d, FromField e) =>
-    FromRow (a,b,c,d,e) where
-    fromRow = (,,,,) <$> field <*> field <*> field <*> field <*> field
-
 instance (FromField a, FromField b, FromField c, FromField d, FromField e) =>
     FromRow (Maybe (a,b,c,d,e)) where
     fromRow =  (null *> null *> null *> null *> null *> pure Nothing)
            <|> (Just <$> fromRow)
 
-instance (FromField a, FromField b, FromField c, FromField d, FromField e,
-          FromField f) =>
-    FromRow (a,b,c,d,e,f) where
-    fromRow = (,,,,,) <$> field <*> field <*> field <*> field <*> field
-                      <*> field
-
 instance (FromField a, FromField b, FromField c, FromField d, FromField e,
           FromField f) =>
     FromRow (Maybe (a,b,c,d,e,f)) where
     fromRow =  (null *> null *> null *> null *> null *>
                 null *> pure Nothing)
            <|> (Just <$> fromRow)
 
-instance (FromField a, FromField b, FromField c, FromField d, FromField e,
-          FromField f, FromField g) =>
-    FromRow (a,b,c,d,e,f,g) where
-    fromRow = (,,,,,,) <$> field <*> field <*> field <*> field <*> field
-                       <*> field <*> field
-
 instance (FromField a, FromField b, FromField c, FromField d, FromField e,
           FromField f, FromField g) =>
     FromRow (Maybe (a,b,c,d,e,f,g)) where
     fromRow =  (null *> null *> null *> null *> null *>
                 null *> null *> pure Nothing)
            <|> (Just <$> fromRow)
 
-instance (FromField a, FromField b, FromField c, FromField d, FromField e,
-          FromField f, FromField g, FromField h) =>
-    FromRow (a,b,c,d,e,f,g,h) where
-    fromRow = (,,,,,,,) <$> field <*> field <*> field <*> field <*> field
-                        <*> field <*> field <*> field
-
 instance (FromField a, FromField b, FromField c, FromField d, FromField e,
           FromField f, FromField g, FromField h) =>
     FromRow (Maybe (a,b,c,d,e,f,g,h)) where
     fromRow =  (null *> null *> null *> null *> null *>
                 null *> null *> null *> pure Nothing)
            <|> (Just <$> fromRow)
 
-instance (FromField a, FromField b, FromField c, FromField d, FromField e,
-          FromField f, FromField g, FromField h, FromField i) =>
-    FromRow (a,b,c,d,e,f,g,h,i) where
-    fromRow = (,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
-                         <*> field <*> field <*> field <*> field
-
 instance (FromField a, FromField b, FromField c, FromField d, FromField e,
           FromField f, FromField g, FromField h, FromField i) =>
     FromRow (Maybe (a,b,c,d,e,f,g,h,i)) where
     fromRow =  (null *> null *> null *> null *> null *>
                 null *> null *> null *> null *> pure Nothing)
            <|> (Just <$> fromRow)
 
-instance (FromField a, FromField b, FromField c, FromField d, FromField e,
-          FromField f, FromField g, FromField h, FromField i, FromField j) =>
-    FromRow (a,b,c,d,e,f,g,h,i,j) where
-    fromRow = (,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
-                          <*> field <*> field <*> field <*> field <*> field
-
 instance (FromField a, FromField b, FromField c, FromField d, FromField e,
           FromField f, FromField g, FromField h, FromField i, FromField j) =>
     FromRow (Maybe (a,b,c,d,e,f,g,h,i,j)) where
@@ -252,3 +209,5 @@ instance FromField a => FromRow (Maybe (Vector a)) where
 
 instance (FromRow a, FromRow b) => FromRow (a :. b) where
     fromRow = (:.) <$> fromRow <*> fromRow
+
+$(mapM Boilerplate.generateTupleInstance [2..30] >>= return . join)

src/Database/PostgreSQL/Simple/FromRow.hs-boot

@@ -2,8 +2,10 @@ module Database.PostgreSQL.Simple.FromRow where
 
 import {-# SOURCE #-} Database.PostgreSQL.Simple.FromField
 import                Database.PostgreSQL.Simple.Types
+import                Database.PostgreSQL.Simple.Internal
 
-class FromRow a
+class FromRow a where
+    fromRow :: RowParser a
 
 instance (FromField a) => FromRow (Only a)
 instance (FromField a, FromField b)
@@ -16,3 +18,4 @@ instance (FromField a, FromField b, FromField c, FromField d, FromField e
          ,FromField f) 
       => FromRow (a,b,c,d,e,f)
 
+field :: FromField a => RowParser a

src/Database/PostgreSQL/Simple/FromRow/Boilerplate.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Database.PostgreSQL.Simple.FromRow.Boilerplate where
+
+import Prelude
+import Control.Applicative
+import Control.Monad
+import Data.List
+import Language.Haskell.TH
+import {-# SOURCE #-} Database.PostgreSQL.Simple.FromRow
+import {-# SOURCE #-} Database.PostgreSQL.Simple.FromField
+
+generateTupleInstance :: Int -> Q [Dec]
+generateTupleInstance arity =
+  pure $ (:[]) $ InstanceD constraints instanceHead decs
+  where
+    compositeType = foldl AppT (TupleT arity) typeVars
+    typeVars = do
+      i <- take arity [1..]
+      return $ VarT $ mkName $ '_' : show i
+    constraints = do
+      typeVar <- typeVars
+      return $ ClassP ''FromField [typeVar]
+    instanceHead = ConT ''FromRow `AppT` compositeType
+    decs = [fromRowDec]
+      where
+        fromRowDec = FunD 'fromRow [Clause [] (NormalB body) []]
+          where
+            body = processQueue queue
+              where
+                con = ConE $ tupleDataName arity
+                queue =
+                  (con :) $
+                  (VarE '(<$>) :) $
+                  intersperse (VarE '(<*>)) $
+                  replicate arity (VarE 'field)
+                processQueue q = case q of
+                  e : o : tail -> UInfixE e o (processQueue tail)
+                  e : [] -> e
+                  _ -> error $ "Unexpected queue size"