{-# LANGUAGE GADTs, TypeFamilies, TypeOperators, PolyKinds #-}
{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables #-}
{-# LANGUAGE DataKinds, UndecidableInstances, MultiParamTypeClasses #-}
-- | Columns and associated utility functions, specialized to 'SQL'.
module Database.Selda.Column
( Columns, Same
, Row (..), Col (..), SomeCol (..), UntypedCol (..)
, Exp (..), NulOp (..), UnOp (..), BinOp (..)
, toTup, fromTup, liftC, liftC2, liftC3
, allNamesIn
, hideRenaming
, literal
) where
import Database.Selda.Exp
import Database.Selda.SQL
import Database.Selda.SqlType
import Database.Selda.SqlRow
import Database.Selda.Types
import Data.Proxy
import Data.String
import Data.Text (Text)
import GHC.TypeLits as TL
-- | Any column tuple.
class Columns a where
toTup :: [ColName] -> a
fromTup :: a -> [UntypedCol SQL]
instance (SqlType a, Columns b) => Columns (Col s a :*: b) where
toTup (x:xs) = One (Col x) :*: toTup xs
toTup [] = error "too few elements to toTup"
fromTup (One x :*: xs) = Untyped x : fromTup xs
instance (SqlRow a, Columns b) => Columns (Row s a :*: b) where
toTup xs =
case nestedCols (Proxy :: Proxy a) of
n -> Many (map (Untyped . Col) (take n xs)) :*: toTup (drop n xs)
fromTup (Many xs :*: xss) = xs ++ fromTup xss
instance Columns (Col s a) where
toTup [x] = One (Col x)
toTup [] = error "too few elements to toTup"
toTup _ = error "too many elements to toTup"
fromTup (One x) = [Untyped x]
instance Columns (Row s a) where
toTup xs = Many (map (Untyped . Col) xs)
fromTup (Many xs) = xs
-- | 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 = One (Exp SQL a)
-- | A database row. A row is a collection of one or more columns.
newtype Row s a = Many [UntypedCol SQL]
-- | A literal expression.
literal :: SqlType a => a -> Col s a
literal = One . 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 (One a) (One b) (One c) = One (f a b c)
-- | Denotes that scopes @s@ and @t@ are identical.
class s ~ t => Same s t where
liftC2 :: (Exp SQL a -> Exp SQL b -> Exp SQL c) -> Col s a -> Col t b -> Col s c
liftC2 f (One a) (One b) = One (f a b)
instance {-# OVERLAPPING #-} Same s s
instance {-# OVERLAPPABLE #-} (s ~ t, TypeError
('TL.Text "An identifier from an outer scope may not be used in an inner query."))
=> Same s t
liftC :: (Exp SQL a -> Exp SQL b) -> Col s a -> Col s b
liftC f (One x) = One (f x)
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 Fractional (Col s Double) where
fromRational = literal . fromRational
(/) = liftC2 $ BinOp Div
instance Fractional (Col s Int) where
fromRational = literal . (truncate :: Double -> Int) . fromRational
(/) = liftC2 $ BinOp Div