{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, DataKinds, DefaultSignatures, TemplateHaskell, TypeFamilies #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE UndecidableSuperClasses #-}
#endif
-- |
-- Module: Database.PostgreSQL.Typed.Dynamic
-- Copyright: 2015 Dylan Simon
-- 
-- Automatic (dynamic) marshalling of PostgreSQL values based on Haskell types (not SQL statements).
-- This is intended for direct construction of queries and query data, bypassing the normal SQL type inference.

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

-- |Represents canonical/default PostgreSQL representation for various Haskell types, allowing convenient type-driven marshalling.
class (PGParameter (PGRepType a) a, PGColumn (PGRepType a) a) => PGRep a where
  -- |The PostgreSOL type that this type should be converted to.
  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

-- |Encode a value using 'pgEncodeValue'.
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

-- |Produce a literal value for interpolation in a SQL statement using 'pgLiteral'.  Using 'pgSafeLiteral' is usually safer as it includes type cast.
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

-- |Decode a value using 'pgDecodeValue'.
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))

-- |Produce a raw SQL literal from a value. Using 'pgSafeLiteral' is usually safer when interpolating in a SQL statement.
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

-- |Produce a safely type-cast literal value for interpolation in a SQL statement, e.g., "'123'::integer".
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))

-- |Identical to @'BSC.unpack' . 'pgSafeLiteral'@ but more efficient.
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" -- superset of "name"
#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

-- |Create an expression that literally substitutes each instance of @${expr}@ for the result of @pgSafeLiteral expr@, producing a lazy 'BSL.ByteString'.
-- This lets you do safe, type-driven literal substitution into SQL fragments without needing a full query, bypassing placeholder inference and any prepared queries, for example when using 'Database.PostgreSQL.Typed.Protocol.pgSimpleQuery' or 'Database.PostgreSQL.Typed.Protocol.pgSimpleQueries_'.
-- Unlike most other TH functions, this does not require any database connection.
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)