{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ConstraintKinds #-}
{-# LANGUAGE GADTs, CPP, DeriveGeneric, DataKinds #-}
module Database.Selda.Table
( Attr (..), Table (..), Attribute
, ColInfo (..), ColAttr (..), IndexMethod (..)
, ForeignKey (..)
, table, tableFieldMod
, primary, autoPrimary, untypedAutoPrimary, unique
, index, indexUsing
, tableExpr
) where
import Data.Text (Text)
#if MIN_VERSION_base(4, 10, 0)
import Data.Typeable
#else
import Data.Proxy
#endif
import Database.Selda.Types
import Database.Selda.Selectors
import Database.Selda.SqlType
import Database.Selda.Column (Row (..))
import Database.Selda.Generic
import Database.Selda.Table.Type
import Database.Selda.Table.Validation (snub)
data Attr a where
(:-) :: Selector a b -> Attribute a b -> Attr a
table :: forall a. Relational a
=> TableName
-> [Attr a]
-> Table a
table tn attrs = tableFieldMod tn attrs id
tableFieldMod :: forall a. Relational a
=> TableName
-> [Attr a]
-> (Text -> Text)
-> Table a
tableFieldMod tn attrs fieldMod = Table
{ tableName = tn
, tableCols = map tidy cols
, tableHasAutoPK = apk
}
where
cols = zipWith addAttrs [0..] (tblCols (Proxy :: Proxy a) fieldMod)
apk = or [AutoIncrement `elem` as | _ :- Attribute as <- attrs]
addAttrs n ci = ci
{ colAttrs = colAttrs ci ++ concat
[ as
| sel :- Attribute as <- attrs
, selectorIndex sel == n
]
, colFKs = colFKs ci ++
[ thefk
| sel :- ForeignKey thefk <- attrs
, selectorIndex sel == n
]
}
tidy :: ColInfo -> ColInfo
tidy ci = ci {colAttrs = snub $ colAttrs ci}
data Attribute t c
= Attribute [ColAttr]
| ForeignKey (Table (), ColName)
primary :: Attribute t c
primary = Attribute [Primary, Required, Unique]
index :: Attribute t c
index = Attribute [Indexed Nothing]
indexUsing :: IndexMethod -> Attribute t c
indexUsing m = Attribute [Indexed (Just m)]
autoPrimary :: Attribute t (ID t)
autoPrimary = Attribute [Primary, AutoIncrement, Required, Unique]
untypedAutoPrimary :: Attribute t RowID
untypedAutoPrimary = Attribute [Primary, AutoIncrement, Required, Unique]
unique :: Attribute t c
unique = Attribute [Unique]
mkFK :: Table t -> Selector a b -> Attribute c d
mkFK (Table tn tcs tapk) sel =
ForeignKey (Table tn tcs tapk, colName (tcs !! selectorIndex sel))
class ForeignKey a b where
foreignKey :: Table t -> Selector t a -> Attribute self b
instance ForeignKey a a where
foreignKey = mkFK
instance ForeignKey (Maybe a) a where
foreignKey = mkFK
instance ForeignKey a (Maybe a) where
foreignKey = mkFK
tableExpr :: Table a -> Row s a
tableExpr = Many . map colExpr . tableCols