Add To/FromField instances for Const

src/Database/PostgreSQL/Simple/FromField.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
 {-# LANGUAGE PatternGuards, ScopedTypeVariables      #-}
 {-# LANGUAGE RecordWildCards                         #-}
+{-# LANGUAGE KindSignatures, PolyKinds #-}
 
 {- |
 Module:      Database.PostgreSQL.Simple.FromField
@@ -113,7 +114,7 @@ module Database.PostgreSQL.Simple.FromField
 
 #include "MachDeps.h"
 
-import           Control.Applicative ( (<|>), (<$>), pure, (*>), (<*) )
+import           Control.Applicative ( Const(Const), (<|>), (<$>), pure, (*>), (<*) )
 import           Control.Concurrent.MVar (MVar, newMVar)
 import           Control.Exception (Exception)
 import qualified Data.Aeson as JSON
@@ -122,6 +123,7 @@ import qualified Data.Aeson.Parser as JSON (value')
 import           Data.Attoparsec.ByteString.Char8 hiding (Result)
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as B
+import           Data.Functor.Identity (Identity(Identity))
 import           Data.Int (Int16, Int32, Int64)
 import           Data.IORef (IORef, newIORef)
 import           Data.Ratio (Ratio)
@@ -152,6 +154,11 @@ import qualified Data.UUID.Types as UUID
 import           Data.Scientific (Scientific)
 import           GHC.Real (infinity, notANumber)
 
+#if MIN_VERSION_base(4,9,0)
+#else
+#define Type *
+#endif
+
 -- | Exception thrown if conversion from a SQL value to a Haskell
 -- value fails.
 data ResultError = Incompatible { errSQLType :: String
@@ -267,6 +274,17 @@ instance FromField () where
      | typeOid f /= TI.voidOid = returnError Incompatible f ""
      | otherwise = pure ()
 
+#if MIN_VERSION_base(4,9,0)
+instance (FromField a) => FromField (Const a (b :: k)) where
+  fromField f bs = Const <$> fromField f bs
+#else
+instance (FromField a) => FromField (Const a (b :: Type)) where
+  fromField f bs = Const <$> fromField f bs
+#endif
+
+instance (FromField a) => FromField (Identity a) where
+  fromField f bs = Identity <$> fromField f bs
+
 -- | For dealing with null values.  Compatible with any postgresql type
 --   compatible with type @a@.  Note that the type is not checked if
 --   the value is null, although it is inadvisable to rely on this

src/Database/PostgreSQL/Simple/ToField.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor  #-}
 {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
+{-# LANGUAGE KindSignatures, PolyKinds #-}
 
 ------------------------------------------------------------------------------
 -- |
@@ -22,6 +23,7 @@ module Database.PostgreSQL.Simple.ToField
     , inQuotes
     ) where
 
+import Control.Applicative (Const(Const))
 import qualified Data.Aeson as JSON
 import           Data.ByteString (ByteString)
 import           Data.ByteString.Builder
@@ -30,6 +32,7 @@ import           Data.ByteString.Builder
                    , wordDec, word8Dec, word16Dec, word32Dec, word64Dec
                    , floatDec, doubleDec
                    )
+import Data.Functor.Identity (Identity(Identity))
 import Data.Int (Int8, Int16, Int32, Int64)
 import Data.List (intersperse)
 import Data.Monoid (mappend)
@@ -62,6 +65,11 @@ import           Data.Scientific (scientificBuilder)
 #endif
 import           Foreign.C.Types (CUInt(..))
 
+#if MIN_VERSION_base(4,9,0)
+#else
+#define Type *
+#endif
+
 -- | How to render an element when substituting it into a query.
 data Action =
     Plain Builder
@@ -100,6 +108,20 @@ instance ToField Action where
     toField a = a
     {-# INLINE toField #-}
 
+#if MIN_VERSION_base(4,9,0)
+instance (ToField a) => ToField (Const a (b :: k)) where
+  toField (Const a) = toField a
+  {-# INLINE toField #-}
+#else
+instance (ToField a) => ToField (Const a (b :: Type)) where
+  toField (Const a) = toField a
+  {-# INLINE toField #-}
+#endif
+
+instance (ToField a) => ToField (Identity a) where
+  toField (Identity a) = toField a
+  {-# INLINE toField #-}
+
 instance (ToField a) => ToField (Maybe a) where
     toField Nothing  = renderNull
     toField (Just a) = toField a