{-# 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