{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, DataKinds, DefaultSignatures, TemplateHaskell, TypeFamilies #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE UndecidableSuperClasses #-}
#endif
module Database.PostgreSQL.Typed.Dynamic
( PGRep(..)
, pgTypeOf
, pgTypeOfProxy
, pgEncodeRep
, pgDecodeRep
, pgLiteralRep
, pgLiteralString
, pgSafeLiteral
, pgSafeLiteralString
, pgSubstituteLiterals
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
#ifdef VERSION_aeson
import qualified Data.Aeson as JSON
#endif
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.ByteString.Internal (w2c)
import qualified Data.ByteString.Lazy as BSL
import Data.Int
import Data.Monoid ((<>))
import Data.Proxy (Proxy)
#ifdef VERSION_scientific
import Data.Scientific (Scientific)
#endif
import Data.String (fromString)
#ifdef VERSION_text
import qualified Data.Text as T
#endif
import qualified Data.Time as Time
#ifdef VERSION_uuid
import qualified Data.UUID as UUID
#endif
import GHC.TypeLits (Symbol)
import Language.Haskell.Meta.Parse (parseExp)
import qualified Language.Haskell.TH as TH
import Database.PostgreSQL.Typed.Types
import Database.PostgreSQL.Typed.SQLToken
class (PGParameter (PGRepType a) a, PGColumn (PGRepType a) a) => PGRep a where
type PGRepType a :: Symbol
pgTypeOf :: a -> PGTypeID (PGRepType a)
pgTypeOf :: forall a. a -> PGTypeID (PGRepType a)
pgTypeOf a
_ = forall (t :: Symbol). PGTypeID t
PGTypeProxy
pgTypeOfProxy :: Proxy a -> PGTypeID (PGRepType a)
pgTypeOfProxy :: forall a. Proxy a -> PGTypeID (PGRepType a)
pgTypeOfProxy Proxy a
_ = forall (t :: Symbol). PGTypeID t
PGTypeProxy
pgEncodeRep :: PGRep a => a -> PGValue
pgEncodeRep :: forall a. PGRep a => a -> PGValue
pgEncodeRep a
x = forall (t :: Symbol) a.
PGParameter t a =>
PGTypeEnv -> PGTypeID t -> a -> PGValue
pgEncodeValue PGTypeEnv
unknownPGTypeEnv (forall a. a -> PGTypeID (PGRepType a)
pgTypeOf a
x) a
x
pgLiteralRep :: PGRep a => a -> BS.ByteString
pgLiteralRep :: forall a. PGRep a => a -> ByteString
pgLiteralRep a
x = forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgLiteral (forall a. a -> PGTypeID (PGRepType a)
pgTypeOf a
x) a
x
pgDecodeRep :: forall a . PGRep a => PGValue -> a
pgDecodeRep :: forall a. PGRep a => PGValue -> a
pgDecodeRep = forall (t :: Symbol) a.
PGColumn t a =>
PGTypeEnv -> PGTypeID t -> PGValue -> a
pgDecodeValue PGTypeEnv
unknownPGTypeEnv (forall (t :: Symbol). PGTypeID t
PGTypeProxy :: PGTypeID (PGRepType a))
pgLiteralString :: PGRep a => a -> String
pgLiteralString :: forall a. PGRep a => a -> String
pgLiteralString = ByteString -> String
BSC.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PGRep a => a -> ByteString
pgLiteralRep
pgSafeLiteral :: PGRep a => a -> BS.ByteString
pgSafeLiteral :: forall a. PGRep a => a -> ByteString
pgSafeLiteral a
x = forall a. PGRep a => a -> ByteString
pgLiteralRep a
x forall a. Semigroup a => a -> a -> a
<> String -> ByteString
BSC.pack String
"::" forall a. Semigroup a => a -> a -> a
<> PGName -> ByteString
pgNameBS (forall (t :: Symbol). PGType t => PGTypeID t -> PGName
pgTypeName (forall a. a -> PGTypeID (PGRepType a)
pgTypeOf a
x))
pgSafeLiteralString :: PGRep a => a -> String
pgSafeLiteralString :: forall a. PGRep a => a -> String
pgSafeLiteralString a
x = forall a. PGRep a => a -> String
pgLiteralString a
x forall a. [a] -> [a] -> [a]
++ String
"::" forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Char
w2c (PGName -> [Word8]
pgNameBytes (forall (t :: Symbol). PGType t => PGTypeID t -> PGName
pgTypeName (forall a. a -> PGTypeID (PGRepType a)
pgTypeOf a
x)))
instance PGRep a => PGRep (Maybe a) where
type PGRepType (Maybe a) = PGRepType a
instance PGRep () where
type PGRepType () = "void"
instance PGRep Bool where
type PGRepType Bool = "boolean"
instance PGRep OID where
type PGRepType OID = "oid"
instance PGRep Int16 where
type PGRepType Int16 = "smallint"
instance PGRep Int32 where
type PGRepType Int32 = "integer"
instance PGRep Int64 where
type PGRepType Int64 = "bigint"
instance PGRep Float where
type PGRepType Float = "real"
instance PGRep Double where
type PGRepType Double = "double precision"
instance PGRep Char where
type PGRepType Char = "\"char\""
instance PGRep String where
type PGRepType String = "text"
instance PGRep BS.ByteString where
type PGRepType BS.ByteString = "text"
instance PGRep PGName where
type PGRepType PGName = "text"
#ifdef VERSION_text
instance PGRep T.Text where
type PGRepType T.Text = "text"
#endif
instance PGRep Time.Day where
type PGRepType Time.Day = "date"
instance PGRep Time.TimeOfDay where
type PGRepType Time.TimeOfDay = "time without time zone"
instance PGRep (Time.TimeOfDay, Time.TimeZone) where
type PGRepType (Time.TimeOfDay, Time.TimeZone) = "time with time zone"
instance PGRep Time.LocalTime where
type PGRepType Time.LocalTime = "timestamp without time zone"
instance PGRep Time.UTCTime where
type PGRepType Time.UTCTime = "timestamp with time zone"
instance PGRep Time.DiffTime where
type PGRepType Time.DiffTime = "interval"
instance PGRep Rational where
type PGRepType Rational = "numeric"
#ifdef VERSION_scientific
instance PGRep Scientific where
type PGRepType Scientific = "numeric"
#endif
#ifdef VERSION_uuid
instance PGRep UUID.UUID where
type PGRepType UUID.UUID = "uuid"
#endif
#ifdef VERSION_aeson
instance PGRep JSON.Value where
type PGRepType JSON.Value = "jsonb"
#endif
pgSubstituteLiterals :: String -> TH.ExpQ
pgSubstituteLiterals :: String -> ExpQ
pgSubstituteLiterals String
sql = Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE 'BSL.fromChunks) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Exp] -> Exp
TH.ListE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}. MonadFail m => SQLToken -> m Exp
sst (String -> [SQLToken]
sqlTokens String
sql) where
sst :: SQLToken -> m Exp
sst (SQLExpr String
e) = do
Exp
v <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a] -> [a]
(++) (String
"Failed to parse expression {" forall a. [a] -> [a] -> [a]
++ String
e forall a. [a] -> [a] -> [a]
++ String
"}: ")) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Either String Exp
parseExp String
e
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
TH.VarE 'pgSafeLiteral Exp -> Exp -> Exp
`TH.AppE` Exp
v
sst SQLToken
t = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
TH.VarE 'fromString Exp -> Exp -> Exp
`TH.AppE` Lit -> Exp
TH.LitE (String -> Lit
TH.StringL forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SQLToken
t)