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