SqlType.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Database.PostgreSQL.ORM.SqlType (SqlType(..), getTypeOid) where

import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Int
import Data.Monoid
import qualified Data.Text as ST
import qualified Data.Text.Lazy as LT
import Data.Time
import Data.Typeable
import qualified Data.Vector as V
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.FromField
import Database.PostgreSQL.Simple.Time
import Database.PostgreSQL.Simple.ToField
import Database.PostgreSQL.Simple.TypeInfo.Static
import Database.PostgreSQL.Simple.Types

import Database.PostgreSQL.ORM.Model

newtype ExtractTypeOid = ExtractTypeOid Oid
instance FromField ExtractTypeOid where
  fromField f _ = return $ ExtractTypeOid $ typeOid f

-- | Retreive the 'Oid' corresponding to a type.  You can subsequently
-- use the 'Oid' to call 'getTypeInfo' for more information on the
-- type.
getTypeOid :: Connection -> S.ByteString -> IO Oid
getTypeOid c tname = do
  [Only (ExtractTypeOid ti)] <- query_ c $ Query $ "SELECT NULL :: " <> tname
  return ti

-- | The class of Haskell types that can be converted to and from a
-- particular SQL type.  For most instances, you only need to define
-- 'sqlBaseType'.
class (ToField a, FromField a) => SqlType a where
  sqlBaseType :: a -> S.ByteString
  -- ^ The name of the SQL type corresponding to Haskell type @a@,
  -- when a value of @a@ can be null.  This is the SQL type to and
  -- from which a @'Maybe' a@ will be converted (where 'Nothing'
  -- corresponds to the SQL value null).
  sqlType :: a -> S.ByteString
  -- ^ The name of the SQL type corresponding to Haskell type @a@,
  -- when @a@ is not wrapped in 'Maybe' and hence cannot be null.  If
  -- @sqlType@ is unspecified, the default is to append \"@NOT NULL@\"
  -- to 'sqlBaseType'.
  {-# INLINE sqlType #-}
  sqlType _ = (sqlBaseType (undefined :: a)) <> " NOT NULL"

#define TYPE(hs, sql) \
    instance SqlType (hs) where sqlBaseType _ = typname (sql)
TYPE(Bool, bool)
TYPE(Double, float8)
TYPE(Float, float4)
TYPE(Int16, int2)
TYPE(Int32, int4)
TYPE(Int64, int8)
TYPE(S.ByteString, text)
TYPE(L.ByteString, text)
TYPE(ST.Text, text)
TYPE(LT.Text, text)
TYPE(Oid,oid)
TYPE(LocalTime, timestamp)
TYPE(ZonedTime, timestamptz)
TYPE(TimeOfDay, time)
TYPE(UTCTime, timestamptz)
TYPE(Day, date)
TYPE(Date, date)
TYPE(ZonedTimestamp, timestamptz)
TYPE(UTCTimestamp, timestamptz)
TYPE(LocalTimestamp, timestamp)
TYPE(String, text)
TYPE(Binary S.ByteString, bytea)
TYPE(Binary L.ByteString, bytea)

#undef TYPE

instance SqlType DBKey where
  sqlType _ = "bigserial UNIQUE NOT NULL PRIMARY KEY"
  sqlBaseType _ = error "DBKey should not be wrapped in type"

instance (SqlType a) => SqlType (Maybe a) where
  sqlType _ = sqlBaseType (undefined :: a)
  sqlBaseType _ = error "Table field Maybe should not be wrapped in other type"

instance (Typeable a, SqlType a) => SqlType (V.Vector a) where
  sqlBaseType _ = sqlBaseType (undefined :: a) <> "[]"

instance (Model a) => SqlType (DBRef a) where
  sqlBaseType (DBRef k) = sqlBaseType k <> ref
    where t = modelInfo :: ModelInfo a
          Just orig = modelOrigTable (modelIdentifiers :: ModelIdentifiers a)
          ref = S.concat [
              " REFERENCES ", quoteIdent orig, "("
              , quoteIdent (modelColumns t !! modelPrimaryColumn t), ")" ]

instance (Model a) => SqlType (DBRefUnique a) where
  sqlBaseType (DBRef k) = sqlBaseType k <> ref
    where t = modelInfo :: ModelInfo a
          Just orig = modelOrigTable (modelIdentifiers :: ModelIdentifiers a)
          ref = S.concat [
              " UNIQUE REFERENCES ", quoteIdent orig , "("
              , quoteIdent (modelColumns t !! modelPrimaryColumn t), ")" ]