{-# LANGUAGE GADTs, TypeFamilies, TypeOperators, PolyKinds, FlexibleInstances #-}
module Database.Selda.Column
( Cols, Columns
, Col (..), SomeCol (..), Exp (..), UnOp (..), BinOp (..)
, toTup, fromTup, liftC, liftC2, liftC3
, allNamesIn
, literal
) where
import Database.Selda.Exp
import Database.Selda.SQL
import Database.Selda.SqlType
import Database.Selda.Types
import Data.String
import Data.Text (Text)
type family Cols s a where
Cols s (a :*: b) = Col s a :*: Cols s b
Cols s a = Col s a
class Columns a where
toTup :: [ColName] -> a
fromTup :: a -> [SomeCol SQL]
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]
newtype Col s a = C {unC :: Exp SQL a}
literal :: SqlType a => a -> Col s a
literal = C . Lit . mkLit
instance IsString (Col s Text) where
fromString = literal . fromString
liftC3 :: (Exp SQL a -> Exp SQL b -> Exp SQL c -> Exp SQL d) -> Col s a -> Col s b -> Col s c -> Col s d
liftC3 f (C a) (C b) (C c) = C (f a b c)
liftC2 :: (Exp SQL a -> Exp SQL b -> Exp SQL c) -> Col s a -> Col s b -> Col s c
liftC2 f (C a) (C b) = C (f a b)
liftC :: (Exp SQL a -> Exp SQL 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