{-# OPTIONS_HADDOCK not-home #-}

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}

module Opaleye.Internal.Column where

import Data.String

import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ

data Nullability = NonNullable | Nullable

-- | A field of a @Select@, of type @sqlType@.  For example a @Field
-- SqlInt4@ is an @int4@ column and a @Field SqlText@ is a @text@
-- column.
newtype Field_ (n :: Nullability) sqlType = Column HPQ.PrimExpr

type Field = Field_ NonNullable
type FieldNullable = Field_ 'Nullable

-- | Only used within a 'Column', to indicate that it can be @NULL@.
-- For example, a 'Column' ('Nullable' @SqlText@) can be @NULL@ but a
-- 'Column' @SqlText@ cannot.
data Nullable a = Nullable_

-- | Do not use. Use 'Field' instead.  Will be removed in a later
-- version.
type family Column a where
  Column (Nullable a) = FieldNullable a
  Column a = Field a

unColumn :: Field_ n a -> HPQ.PrimExpr
unColumn :: Field_ n a -> PrimExpr
unColumn (Column PrimExpr
e) = PrimExpr
e

-- | Treat a 'Column' as though it were of a different type.  If such
-- a treatment is not valid then Postgres may fail with an error at
-- SQL run time.
unsafeCoerceColumn :: Field_ n a -> Field_ n' b
unsafeCoerceColumn :: Field_ n a -> Field_ n' b
unsafeCoerceColumn (Column PrimExpr
e) = PrimExpr -> Field_ n' b
forall (n :: Nullability) sqlType. PrimExpr -> Field_ n sqlType
Column PrimExpr
e

-- | Cast a column to any other type. Implements Postgres's @::@ or
-- @CAST( ... AS ... )@ operations.  This is safe for some
-- conversions, such as uuid to text.
unsafeCast :: String -> Field_ n' a -> Field_ n' b
unsafeCast :: String -> Field_ n' a -> Field_ n' b
unsafeCast = (PrimExpr -> PrimExpr) -> Field_ n' a -> Field_ n' b
forall (n :: Nullability) c (n' :: Nullability) a.
(PrimExpr -> PrimExpr) -> Field_ n c -> Field_ n' a
mapColumn ((PrimExpr -> PrimExpr) -> Field_ n' a -> Field_ n' b)
-> (String -> PrimExpr -> PrimExpr)
-> String
-> Field_ n' a
-> Field_ n' b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PrimExpr -> PrimExpr
HPQ.CastExpr
  where
    mapColumn :: (HPQ.PrimExpr -> HPQ.PrimExpr) -> Field_ n c -> Field_ n' a
    mapColumn :: (PrimExpr -> PrimExpr) -> Field_ n c -> Field_ n' a
mapColumn PrimExpr -> PrimExpr
primExpr Field_ n c
c = PrimExpr -> Field_ n' a
forall (n :: Nullability) sqlType. PrimExpr -> Field_ n sqlType
Column (PrimExpr -> PrimExpr
primExpr (Field_ n c -> PrimExpr
forall (n :: Nullability) a. Field_ n a -> PrimExpr
unColumn Field_ n c
c))

unsafeCompositeField :: Field_ n a -> String -> Field_ n' b
unsafeCompositeField :: Field_ n a -> String -> Field_ n' b
unsafeCompositeField (Column PrimExpr
e) String
fieldName =
  PrimExpr -> Field_ n' b
forall (n :: Nullability) sqlType. PrimExpr -> Field_ n sqlType
Column (PrimExpr -> String -> PrimExpr
HPQ.CompositeExpr PrimExpr
e String
fieldName)

unsafeFromNullable :: Field_ n a
                   -> Field_ n' a
unsafeFromNullable :: Field_ n a -> Field_ n' a
unsafeFromNullable (Column PrimExpr
e) = PrimExpr -> Field_ n' a
forall (n :: Nullability) sqlType. PrimExpr -> Field_ n sqlType
Column PrimExpr
e

binOp :: HPQ.BinOp -> Field_ n a -> Field_ n' b -> Field_ n'' c
binOp :: BinOp -> Field_ n a -> Field_ n' b -> Field_ n'' c
binOp BinOp
op (Column PrimExpr
e) (Column PrimExpr
e') = PrimExpr -> Field_ n'' c
forall (n :: Nullability) sqlType. PrimExpr -> Field_ n sqlType
Column (BinOp -> PrimExpr -> PrimExpr -> PrimExpr
HPQ.BinExpr BinOp
op PrimExpr
e PrimExpr
e')

unOp :: HPQ.UnOp -> Field_ n a -> Field_ n' b
unOp :: UnOp -> Field_ n a -> Field_ n' b
unOp UnOp
op (Column PrimExpr
e) = PrimExpr -> Field_ n' b
forall (n :: Nullability) sqlType. PrimExpr -> Field_ n sqlType
Column (UnOp -> PrimExpr -> PrimExpr
HPQ.UnExpr UnOp
op PrimExpr
e)

-- For import order reasons we can't make the argument type SqlBool
unsafeCase_ :: [(Field_ n pgBool, Field_ n' a)] -> Field_ n' a -> Field_ n' a
unsafeCase_ :: [(Field_ n pgBool, Field_ n' a)] -> Field_ n' a -> Field_ n' a
unsafeCase_ [(Field_ n pgBool, Field_ n' a)]
alts (Column PrimExpr
otherwise_) = PrimExpr -> Field_ n' a
forall (n :: Nullability) sqlType. PrimExpr -> Field_ n sqlType
Column ([(PrimExpr, PrimExpr)] -> PrimExpr -> PrimExpr
HPQ.CaseExpr ([(Field_ n pgBool, Field_ n' a)] -> [(PrimExpr, PrimExpr)]
forall (n :: Nullability) sqlType (n :: Nullability) sqlType.
[(Field_ n sqlType, Field_ n sqlType)] -> [(PrimExpr, PrimExpr)]
unColumns [(Field_ n pgBool, Field_ n' a)]
alts) PrimExpr
otherwise_)
  where unColumns :: [(Field_ n sqlType, Field_ n sqlType)] -> [(PrimExpr, PrimExpr)]
unColumns = ((Field_ n sqlType, Field_ n sqlType) -> (PrimExpr, PrimExpr))
-> [(Field_ n sqlType, Field_ n sqlType)] -> [(PrimExpr, PrimExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Column PrimExpr
e, Column PrimExpr
e') -> (PrimExpr
e, PrimExpr
e'))

unsafeIfThenElse :: Field_ n' pgBool -> Field_ n a -> Field_ n a -> Field_ n a
unsafeIfThenElse :: Field_ n' pgBool -> Field_ n a -> Field_ n a -> Field_ n a
unsafeIfThenElse Field_ n' pgBool
cond Field_ n a
t Field_ n a
f = [(Field_ n' pgBool, Field_ n a)] -> Field_ n a -> Field_ n a
forall (n :: Nullability) pgBool (n' :: Nullability) a.
[(Field_ n pgBool, Field_ n' a)] -> Field_ n' a -> Field_ n' a
unsafeCase_ [(Field_ n' pgBool
cond, Field_ n a
t)] Field_ n a
f

unsafeGt :: Field_ n a -> Field_ n a -> Field_ n' pgBool
unsafeGt :: Field_ n a -> Field_ n a -> Field_ n' pgBool
unsafeGt = BinOp -> Field_ n a -> Field_ n a -> Field_ n' pgBool
forall (n :: Nullability) a (n' :: Nullability) b
       (n'' :: Nullability) c.
BinOp -> Field_ n a -> Field_ n' b -> Field_ n'' c
binOp BinOp
(HPQ.:>)

unsafeEq :: Field_ n a -> Field_ n a -> Field_ n' pgBool
unsafeEq :: Field_ n a -> Field_ n a -> Field_ n' pgBool
unsafeEq = BinOp -> Field_ n a -> Field_ n a -> Field_ n' pgBool
forall (n :: Nullability) a (n' :: Nullability) b
       (n'' :: Nullability) c.
BinOp -> Field_ n a -> Field_ n' b -> Field_ n'' c
binOp BinOp
(HPQ.:==)

class SqlNum a where
  pgFromInteger :: Integer -> Field a
  pgFromInteger = Integer -> Field a
forall a. SqlNum a => Integer -> Field a
sqlFromInteger

  sqlFromInteger :: Integer -> Field a

type PGNum = SqlNum

instance SqlNum a => Num (Field a) where
  fromInteger :: Integer -> Field a
fromInteger = Integer -> Field a
forall a. SqlNum a => Integer -> Field a
pgFromInteger
  * :: Field a -> Field a -> Field a
(*) = BinOp -> Field a -> Field a -> Field a
forall (n :: Nullability) a (n' :: Nullability) b
       (n'' :: Nullability) c.
BinOp -> Field_ n a -> Field_ n' b -> Field_ n'' c
binOp BinOp
(HPQ.:*)
  + :: Field a -> Field a -> Field a
(+) = BinOp -> Field a -> Field a -> Field a
forall (n :: Nullability) a (n' :: Nullability) b
       (n'' :: Nullability) c.
BinOp -> Field_ n a -> Field_ n' b -> Field_ n'' c
binOp BinOp
(HPQ.:+)
  (-) = BinOp -> Field a -> Field a -> Field a
forall (n :: Nullability) a (n' :: Nullability) b
       (n'' :: Nullability) c.
BinOp -> Field_ n a -> Field_ n' b -> Field_ n'' c
binOp BinOp
(HPQ.:-)

  abs :: Field a -> Field a
abs = UnOp -> Field a -> Field a
forall (n :: Nullability) a (n' :: Nullability) b.
UnOp -> Field_ n a -> Field_ n' b
unOp UnOp
HPQ.OpAbs
  negate :: Field a -> Field a
negate = UnOp -> Field a -> Field a
forall (n :: Nullability) a (n' :: Nullability) b.
UnOp -> Field_ n a -> Field_ n' b
unOp UnOp
HPQ.OpNegate

  -- We can't use Postgres's 'sign' function because it returns only a
  -- numeric or a double
  signum :: Field a -> Field a
signum Field a
c = [(Field_ Any Any, Field a)] -> Field a -> Field a
forall (n :: Nullability) pgBool (n' :: Nullability) a.
[(Field_ n pgBool, Field_ n' a)] -> Field_ n' a -> Field_ n' a
unsafeCase_ [(Field a
c Field a -> Field a -> Field_ Any Any
forall (n :: Nullability) a (n' :: Nullability) pgBool.
Field_ n a -> Field_ n a -> Field_ n' pgBool
`unsafeGt` Field a
0, Field a
1), (Field a
c Field a -> Field a -> Field_ Any Any
forall (n :: Nullability) a (n' :: Nullability) pgBool.
Field_ n a -> Field_ n a -> Field_ n' pgBool
`unsafeEq` Field a
0, Field a
0)] (-Field a
1)

class SqlFractional a where
  pgFromRational :: Rational -> Field a
  pgFromRational = Rational -> Field a
forall a. SqlFractional a => Rational -> Field a
sqlFromRational

  sqlFromRational :: Rational -> Field a

type PGFractional = SqlFractional

instance (SqlNum a, SqlFractional a) => Fractional (Field a) where
  fromRational :: Rational -> Field a
fromRational = Rational -> Field a
forall a. SqlFractional a => Rational -> Field a
sqlFromRational
  / :: Field a -> Field a -> Field a
(/) = BinOp -> Field a -> Field a -> Field a
forall (n :: Nullability) a (n' :: Nullability) b
       (n'' :: Nullability) c.
BinOp -> Field_ n a -> Field_ n' b -> Field_ n'' c
binOp BinOp
(HPQ.:/)

-- | A dummy typeclass whose instances support integral operations.
class SqlIntegral a

type PGIntegral = SqlIntegral

class SqlString a where
    pgFromString :: String -> Field a
    pgFromString = String -> Field a
forall a. SqlString a => String -> Field a
sqlFromString

    sqlFromString :: String -> Field a

type PGString = SqlString

instance SqlString a => IsString (Field a) where
  fromString :: String -> Field a
fromString = String -> Field a
forall a. SqlString a => String -> Field a
sqlFromString