diff --git a/postgresql-simple.cabal b/postgresql-simple.cabal index 9d359c14..1f3d116a 100644 --- a/postgresql-simple.cabal +++ b/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 diff --git a/src/Database/PostgreSQL/Simple/FromRow.hs b/src/Database/PostgreSQL/Simple/FromRow.hs index bed5b7df..08560593 100644 --- a/src/Database/PostgreSQL/Simple/FromRow.hs +++ b/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,44 +134,24 @@ 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 @@ -178,12 +159,6 @@ instance (FromField a, FromField b, FromField c, FromField d, FromField e, 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 @@ -191,12 +166,6 @@ instance (FromField a, FromField b, FromField c, FromField d, FromField e, 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 @@ -204,12 +173,6 @@ instance (FromField a, FromField b, FromField c, FromField d, FromField e, 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 @@ -217,12 +180,6 @@ instance (FromField a, FromField b, FromField c, FromField d, FromField e, 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) diff --git a/src/Database/PostgreSQL/Simple/FromRow.hs-boot b/src/Database/PostgreSQL/Simple/FromRow.hs-boot index 62b7ae60..4fdb6b3b 100644 --- a/src/Database/PostgreSQL/Simple/FromRow.hs-boot +++ b/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 diff --git a/src/Database/PostgreSQL/Simple/FromRow/Boilerplate.hs b/src/Database/PostgreSQL/Simple/FromRow/Boilerplate.hs new file mode 100644 index 00000000..ad9b9092 --- /dev/null +++ b/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"