{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ConstraintKinds #-}
{-# LANGUAGE GADTs, CPP, DataKinds #-}
{-# LANGUAGE TypeApplications #-}
module Database.Selda.Table
( SelectorLike, Group (..), Attr (..), Table (..), Attribute
, ColInfo (..), AutoIncType (..), ColAttr (..), IndexMethod (..)
, ForeignKey (..)
, table, tableFieldMod
, primary, autoPrimary, weakAutoPrimary
, untypedAutoPrimary, weakUntypedAutoPrimary
, unique
, index, indexUsing
, tableExpr
, isAutoPrimary, isPrimary, isUnique
) where
import Data.Text (Text)
import Data.Typeable ( Proxy(..) )
import Database.Selda.Types ( type (:*:), TableName, ColName )
import Database.Selda.Selectors ( Selector(..) )
import Database.Selda.SqlType ( ID, RowID )
import Database.Selda.Column (Row (..))
import Database.Selda.Generic ( Relational, tblCols )
import Database.Selda.Table.Type
( IndexMethod(..),
ColAttr(..),
AutoIncType(..),
ColInfo(..),
Table(..),
isAutoPrimary,
isPrimary,
isUnique )
import Database.Selda.Table.Validation (snub)
import GHC.OverloadedLabels ( IsLabel(..) )
instance forall x t a. IsLabel x (Selector t a) => IsLabel x (Group t a) where
fromLabel :: Group t a
fromLabel = forall t a. Selector t a -> Group t a
Single (forall (x :: Symbol) a. IsLabel x a => a
fromLabel @x)
data Group t a where
(:+) :: Selector t a -> Group t b -> Group t (a :*: b)
Single :: Selector t a -> Group t a
infixr 1 :+
data Attr a where
(:-) :: SelectorLike g => g t a -> Attribute g t a -> Attr t
infixl 0 :-
table :: forall a. Relational a
=> TableName
-> [Attr a]
-> Table a
table :: forall a. Relational a => TableName -> [Attr a] -> Table a
table TableName
tn [Attr a]
attrs = forall a.
Relational a =>
TableName -> [Attr a] -> (Text -> Text) -> Table a
tableFieldMod TableName
tn [Attr a]
attrs forall a. a -> a
id
tableFieldMod :: forall a. Relational a
=> TableName
-> [Attr a]
-> (Text -> Text)
-> Table a
tableFieldMod :: forall a.
Relational a =>
TableName -> [Attr a] -> (Text -> Text) -> Table a
tableFieldMod TableName
tn [Attr a]
attrs Text -> Text
fieldMod = Table
{ tableName :: TableName
tableName = TableName
tn
, tableCols :: [ColInfo]
tableCols = forall a b. (a -> b) -> [a] -> [b]
map ColInfo -> ColInfo
tidy [ColInfo]
cols
, tableHasAutoPK :: Bool
tableHasAutoPK = Bool
apk
, tableAttrs :: [([Int], ColAttr)]
tableAttrs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[([Int], ColAttr)]
combinedAttrs, [([Int], ColAttr)]
pkAttrs]
}
where
combinedAttrs :: [([Int], ColAttr)]
combinedAttrs =
[ ([Int]
ixs, ColAttr
a)
| g a a
sel :- Attribute [ColAttr
a] <- [Attr a]
attrs
, let ixs :: [Int]
ixs = forall (g :: * -> * -> *) t a. SelectorLike g => g t a -> [Int]
indices g a a
sel
, case [Int]
ixs of
(Int
_:Int
_:[Int]
_) -> Bool
True
[Int
_] | ColAttr
a forall a. Eq a => a -> a -> Bool
== ColAttr
Unique -> Bool
True
[Int
_] | Indexed Maybe IndexMethod
_ <- ColAttr
a -> Bool
True
[Int]
_ -> Bool
False
]
pkAttrs :: [([Int], ColAttr)]
pkAttrs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [([Int]
ixs, ColAttr
Primary), ([Int]
ixs, ColAttr
Required)]
| g a a
sel :- Attribute [ColAttr
Primary,ColAttr
Required] <- [Attr a]
attrs
, let ixs :: [Int]
ixs = forall (g :: * -> * -> *) t a. SelectorLike g => g t a -> [Int]
indices g a a
sel
]
cols :: [ColInfo]
cols = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> ColInfo -> ColInfo
addAttrs [Int
0..] (forall a. Relational a => Proxy a -> (Text -> Text) -> [ColInfo]
tblCols (forall {k} (t :: k). Proxy t
Proxy :: Proxy a) Text -> Text
fieldMod)
apk :: Bool
apk = forall (t :: * -> *). Foldable t => t Bool -> Bool
or [forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ColAttr -> Bool
isAutoPrimary [ColAttr]
as | g a a
_ :- Attribute [ColAttr]
as <- [Attr a]
attrs]
addAttrs :: Int -> ColInfo -> ColInfo
addAttrs Int
n ColInfo
ci = ColInfo
ci
{ colAttrs :: [ColAttr]
colAttrs = ColInfo -> [ColAttr]
colAttrs ColInfo
ci forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ColAttr]
as
| g a a
sel :- Attribute [ColAttr]
as <- [Attr a]
attrs
, case forall (g :: * -> * -> *) t a. SelectorLike g => g t a -> [Int]
indices g a a
sel of
[Int
colIx] -> Int
colIx forall a. Eq a => a -> a -> Bool
== Int
n
[Int]
_ -> Bool
False
]
, colFKs :: [(Table (), ColName)]
colFKs = ColInfo -> [(Table (), ColName)]
colFKs ColInfo
ci forall a. [a] -> [a] -> [a]
++
[ (Table (), ColName)
thefk
| g a a
sel :- ForeignKey (Table (), ColName)
thefk <- [Attr a]
attrs
, case forall (g :: * -> * -> *) t a. SelectorLike g => g t a -> [Int]
indices g a a
sel of
[Int
colIx] -> Int
colIx forall a. Eq a => a -> a -> Bool
== Int
n
[Int]
_ -> Bool
False
]
}
class SelectorLike g where
indices :: g t a -> [Int]
instance SelectorLike Selector where
indices :: forall t a. Selector t a -> [Int]
indices Selector t a
s = [forall t a. Selector t a -> Int
selectorIndex Selector t a
s]
instance SelectorLike Group where
indices :: forall t a. Group t a -> [Int]
indices (Selector t a
s :+ Group t b
ss) = forall t a. Selector t a -> Int
selectorIndex Selector t a
s forall a. a -> [a] -> [a]
: forall (g :: * -> * -> *) t a. SelectorLike g => g t a -> [Int]
indices Group t b
ss
indices (Single Selector t a
s) = [forall t a. Selector t a -> Int
selectorIndex Selector t a
s]
tidy :: ColInfo -> ColInfo
tidy :: ColInfo -> ColInfo
tidy ColInfo
ci = ColInfo
ci {colAttrs :: [ColAttr]
colAttrs = forall a. (Ord a, Eq a) => [a] -> [a]
snub forall a b. (a -> b) -> a -> b
$ ColInfo -> [ColAttr]
colAttrs ColInfo
ci}
data Attribute (g :: * -> * -> *) t c
= Attribute [ColAttr]
| ForeignKey (Table (), ColName)
primary :: Attribute Group t a
primary :: forall t a. Attribute Group t a
primary = forall (g :: * -> * -> *) t c. [ColAttr] -> Attribute g t c
Attribute [ColAttr
Primary, ColAttr
Required]
index :: Attribute Group t c
index :: forall t a. Attribute Group t a
index = forall (g :: * -> * -> *) t c. [ColAttr] -> Attribute g t c
Attribute [Maybe IndexMethod -> ColAttr
Indexed forall a. Maybe a
Nothing]
indexUsing :: IndexMethod -> Attribute Group t c
indexUsing :: forall t c. IndexMethod -> Attribute Group t c
indexUsing IndexMethod
m = forall (g :: * -> * -> *) t c. [ColAttr] -> Attribute g t c
Attribute [Maybe IndexMethod -> ColAttr
Indexed (forall a. a -> Maybe a
Just IndexMethod
m)]
autoPrimary :: Attribute Selector t (ID t)
autoPrimary :: forall t. Attribute Selector t (ID t)
autoPrimary = forall (g :: * -> * -> *) t c. [ColAttr] -> Attribute g t c
Attribute [AutoIncType -> ColAttr
AutoPrimary AutoIncType
Strong, ColAttr
Required]
weakAutoPrimary :: Attribute Selector t (ID t)
weakAutoPrimary :: forall t. Attribute Selector t (ID t)
weakAutoPrimary = forall (g :: * -> * -> *) t c. [ColAttr] -> Attribute g t c
Attribute [AutoIncType -> ColAttr
AutoPrimary AutoIncType
Weak, ColAttr
Required]
untypedAutoPrimary :: Attribute Selector t RowID
untypedAutoPrimary :: forall t. Attribute Selector t RowID
untypedAutoPrimary = forall (g :: * -> * -> *) t c. [ColAttr] -> Attribute g t c
Attribute [AutoIncType -> ColAttr
AutoPrimary AutoIncType
Strong, ColAttr
Required]
weakUntypedAutoPrimary :: Attribute Selector t RowID
weakUntypedAutoPrimary :: forall t. Attribute Selector t RowID
weakUntypedAutoPrimary = forall (g :: * -> * -> *) t c. [ColAttr] -> Attribute g t c
Attribute [AutoIncType -> ColAttr
AutoPrimary AutoIncType
Weak, ColAttr
Required]
unique :: Attribute Group t a
unique :: forall t a. Attribute Group t a
unique = forall (g :: * -> * -> *) t c. [ColAttr] -> Attribute g t c
Attribute [ColAttr
Unique]
mkFK :: Table t -> Selector a b -> Attribute Selector c d
mkFK :: forall t a b c d. Table t -> Selector a b -> Attribute Selector c d
mkFK (Table TableName
tn [ColInfo]
tcs Bool
tapk [([Int], ColAttr)]
tas) Selector a b
sel =
forall (g :: * -> * -> *) t c.
(Table (), ColName) -> Attribute g t c
ForeignKey (forall a.
TableName -> [ColInfo] -> Bool -> [([Int], ColAttr)] -> Table a
Table TableName
tn [ColInfo]
tcs Bool
tapk [([Int], ColAttr)]
tas, ColInfo -> ColName
colName ([ColInfo]
tcs forall a. [a] -> Int -> a
!! forall t a. Selector t a -> Int
selectorIndex Selector a b
sel))
class ForeignKey a b where
foreignKey :: Table t -> Selector t a -> Attribute Selector self b
instance ForeignKey a a where
foreignKey :: forall t self. Table t -> Selector t a -> Attribute Selector self a
foreignKey = forall t a b c d. Table t -> Selector a b -> Attribute Selector c d
mkFK
instance ForeignKey (Maybe a) a where
foreignKey :: forall t self.
Table t -> Selector t (Maybe a) -> Attribute Selector self a
foreignKey = forall t a b c d. Table t -> Selector a b -> Attribute Selector c d
mkFK
instance ForeignKey a (Maybe a) where
foreignKey :: forall t self.
Table t -> Selector t a -> Attribute Selector self (Maybe a)
foreignKey = forall t a b c d. Table t -> Selector a b -> Attribute Selector c d
mkFK
tableExpr :: Table a -> Row s a
tableExpr :: forall a s. Table a -> Row s a
tableExpr = forall {k} {k} (s :: k) (a :: k). [UntypedCol SQL] -> Row s a
Many forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ColInfo -> UntypedCol SQL
colExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Table a -> [ColInfo]
tableCols