Column.hs

{-# LANGUAGE GADTs, TypeFamilies, TypeOperators, PolyKinds, FlexibleInstances #-}
-- | Columns and associated utility functions.
module Database.Selda.Column where
import Database.Selda.SqlType
import Database.Selda.Types
import Data.String
import Data.Text (Text)

-- | Convert a tuple of Haskell types to a tuple of column types.
type family Cols s a where
  Cols s (a :*: b)      = Col s a :*: Cols s b
  Cols s a              = Col s a

-- | Any column tuple.
class Columns a where
  toTup :: [ColName] -> a
  fromTup :: a -> [SomeCol]

instance Columns b => Columns (Col s a :*: b) where
  toTup (x:xs) = C (Col x) :*: toTup xs
  toTup _      = error "too few elements to toTup"
  fromTup (C x :*: xs) = Some x : fromTup xs

instance Columns (Col s a) where
  toTup [x] = C (Col x)
  toTup []  = error "too few elements to toTup"
  toTup xs  = C (TblCol xs)
  fromTup (C x) = [Some x]

-- | A type-erased column, which may also be renamed.
--   Only for internal use.
data SomeCol where
  Some  :: !(Exp a) -> SomeCol
  Named :: !ColName -> !(Exp a) -> SomeCol

-- | A database column. A column is often a literal column table, but can also
--   be an expression over such a column or a constant expression.
newtype Col s a = C {unC :: Exp a}

-- | A literal expression.
literal :: SqlType a => a -> Col s a
literal = C . Lit . mkLit

-- | A unary operation. Note that the provided function name is spliced
--   directly into the resulting SQL query. Thus, this function should ONLY
--   be used to implement well-defined functions that are missing from Selda's
--   standard library, and NOT in an ad hoc manner during queries.
fun :: Text -> Col s a -> Col s b
fun f = liftC $ UnOp (Fun f)

-- | Like 'fun', but with two arguments.
fun2 :: Text -> Col s a -> Col s b -> Col s c
fun2 f = liftC2 (Fun2 f)

-- | Underlying column expression type, not tied to any particular query.
data Exp a where
  Col    :: !ColName -> Exp a
  TblCol :: ![ColName] -> Exp a
  Lit    :: !(Lit a) -> Exp a
  BinOp  :: !(BinOp a b) -> !(Exp a) -> !(Exp a) -> Exp b
  UnOp   :: !(UnOp a b) -> !(Exp a) -> Exp b
  Fun2   :: !Text -> !(Exp a) -> !(Exp b) -> Exp c
  Cast   :: !(Exp a) -> Exp b
  AggrEx :: !Text -> !(Exp a) -> Exp b

-- | Get all column names in the given expression.
allNamesIn :: Exp a -> [ColName]
allNamesIn (TblCol ns)   = ns
allNamesIn (Col n)       = [n]
allNamesIn (Lit _)       = []
allNamesIn (BinOp _ a b) = allNamesIn a ++ allNamesIn b
allNamesIn (UnOp _ a)    = allNamesIn a
allNamesIn (Fun2 _ a b)  = allNamesIn a ++ allNamesIn b
allNamesIn (Cast x)      = allNamesIn x
allNamesIn (AggrEx _ x)  = allNamesIn x

data UnOp a b where
  Abs    :: UnOp a a
  Not    :: UnOp Bool Bool
  Neg    :: UnOp a a
  Sgn    :: UnOp a a
  IsNull :: UnOp (Maybe a) Bool
  Fun    :: Text -> UnOp a b

data BinOp a b where
  Gt    :: BinOp a Bool
  Lt    :: BinOp a Bool
  Gte   :: BinOp a Bool
  Lte   :: BinOp a Bool
  Eq    :: BinOp a Bool
  Neq   :: BinOp a Bool
  And   :: BinOp Bool Bool
  Or    :: BinOp Bool Bool
  Add   :: BinOp a a
  Sub   :: BinOp a a
  Mul   :: BinOp a a
  Div   :: BinOp a a
  Like  :: BinOp Text Bool

instance IsString (Col s Text) where
  fromString = literal . fromString

liftC2 :: (Exp a -> Exp b -> Exp c) -> Col s a -> Col s b -> Col s c
liftC2 f (C a) (C b) = C (f a b)

liftC :: (Exp a -> Exp b) -> Col s a -> Col s b
liftC f = C . f . unC

instance (SqlType a, Num a) => Num (Col s a) where
  fromInteger = literal . fromInteger
  (+) = liftC2 $ BinOp Add
  (-) = liftC2 $ BinOp Sub
  (*) = liftC2 $ BinOp Mul
  negate = liftC $ UnOp Neg
  abs = liftC $ UnOp Abs
  signum = liftC $ UnOp Sgn

instance {-# OVERLAPPING #-} (SqlType a, Num a) => Num (Col s (Maybe a)) where
  fromInteger = literal . Just . fromInteger
  (+) = liftC2 $ BinOp Add
  (-) = liftC2 $ BinOp Sub
  (*) = liftC2 $ BinOp Mul
  negate = liftC $ UnOp Neg
  abs = liftC $ UnOp Abs
  signum = liftC $ UnOp Sgn

instance Fractional (Col s Double) where
  fromRational = literal . fromRational
  (/) = liftC2 $ BinOp Div  

instance Fractional (Col s (Maybe Double)) where
  fromRational = literal . Just . fromRational
  (/) = liftC2 $ BinOp Div  

instance Fractional (Col s Int) where
  fromRational = literal . (truncate :: Double -> Int) . fromRational
  (/) = liftC2 $ BinOp Div

instance Fractional (Col s (Maybe Int)) where
  fromRational = literal . Just . (truncate :: Double -> Int) . fromRational
  (/) = liftC2 $ BinOp Div