module Database.Selda.Table where
import Database.Selda.Types
import Database.Selda.SqlType
import Control.Exception
import Data.Dynamic
import Data.List (sort, group)
import Data.Monoid
import Data.Proxy
import Data.Text (unpack, intercalate, any)
data ValidationError = ValidationError String
deriving (Show, Eq, Typeable)
instance Exception ValidationError
data Table a = Table
{
tableName :: !TableName
, tableCols :: ![ColInfo]
, tableHasAutoPK :: !Bool
}
data ColInfo = ColInfo
{ colName :: !ColName
, colType :: !SqlTypeRep
, colAttrs :: ![ColAttr]
, colFKs :: ![(Table (), ColName)]
}
newCol :: forall a. SqlType a => ColName -> ColSpec a
newCol name = ColSpec [ColInfo
{ colName = name
, colType = sqlType (Proxy :: Proxy a)
, colAttrs = []
, colFKs = []
}]
newtype ColSpec a = ColSpec {unCS :: [ColInfo]}
data Nullable
data NotNullable
type family IsNullable a where
IsNullable (Maybe a) = Nullable
IsNullable a = NotNullable
class SqlType a => NonNull a
instance (SqlType a, IsNullable a ~ NotNullable) => NonNull a
data ColAttr = Primary | AutoIncrement | Required | Optional | Unique
deriving (Show, Eq, Ord)
required :: NonNull a => ColName -> ColSpec a
required = addAttr Required . newCol
optional :: NonNull a => ColName -> ColSpec (Maybe a)
optional = addAttr Optional . newCol
primary :: NonNull a => ColName -> ColSpec a
primary = addAttr Primary . unique . required
autoPrimary :: ColName -> ColSpec RowID
autoPrimary n = ColSpec [c {colAttrs = [Primary, AutoIncrement, Required, Unique]}]
where ColSpec [c] = newCol n :: ColSpec RowID
unique :: SqlType a => ColSpec a -> ColSpec a
unique = addAttr Unique
addAttr :: SqlType a => ColAttr -> ColSpec a -> ColSpec a
addAttr attr (ColSpec [ci]) = ColSpec [ci {colAttrs = attr : colAttrs ci}]
addAttr _ _ = error "impossible: ColSpec with several columns"
type family ColSpecs a where
ColSpecs (a :*: b) = ColSpec a :*: ColSpecs b
ColSpecs a = ColSpec a
class TableSpec a where
mergeSpecs :: Proxy a -> ColSpecs a -> [ColInfo]
instance TableSpec b => TableSpec (a :*: b) where
mergeSpecs _ (ColSpec a :*: b) = a ++ mergeSpecs (Proxy :: Proxy b) b
instance ColSpecs a ~ ColSpec a => TableSpec a where
mergeSpecs _ (ColSpec a) = a
table :: forall a. TableSpec a => TableName -> ColSpecs a -> Table a
table name cs = Table
{ tableName = name
, tableCols = tcs
, tableHasAutoPK = Prelude.any ((AutoIncrement `elem`) . colAttrs) tcs
}
where
tcs = validate name $ map tidy $ mergeSpecs (Proxy :: Proxy a) cs
tidy :: ColInfo -> ColInfo
tidy ci = ci {colAttrs = snub $ colAttrs ci}
snub :: (Ord a, Eq a) => [a] -> [a]
snub = map head . soup
soup :: Ord a => [a] -> [[a]]
soup = group . sort
validate :: TableName -> [ColInfo] -> [ColInfo]
validate name cis
| null errs = cis
| otherwise = throw $ ValidationError $ concat
[ "validation of table ", unpack $ fromTableName name, " failed:"
, "\n "
, unpack $ intercalate "\n " errs
]
where
colIdents = map (fromColName . colName) cis
allIdents = fromTableName name : colIdents
errs = concat
[ dupes
, pkDupes
, optionalRequiredMutex
, nulIdents
, emptyIdents
, emptyTableName
, nonPkFks
]
emptyTableName
| fromTableName name == "\"\"" = ["table name is empty"]
| otherwise = []
emptyIdents
| Prelude.any (== "\"\"") colIdents =
["table has columns with empty names"]
| otherwise =
[]
nulIdents =
[ "table or column name contains \\NUL: " <> n
| n <- allIdents
, Data.Text.any (== '\NUL') n
]
dupes =
["duplicate column: " <> fromColName x | (x:_:_) <- soup $ map colName cis]
pkDupes =
["multiple primary keys" | (Primary:_:_) <- soup $ concatMap colAttrs cis]
nonPkFks =
[ "column is used as a foreign key, but is not primary or unique: "
<> fromTableName ftn <> "." <> fromColName fcn
| ci <- cis
, (Table ftn fcs _, fcn) <- colFKs ci
, fc <- fcs
, colName fc == fcn
, not (Unique `elem` colAttrs fc)
]
optionalRequiredMutex =
[ "BUG: column " <> fromColName (colName ci)
<> " is both optional and required"
| ci <- cis
, Optional `elem` colAttrs ci && Required `elem` colAttrs ci
]