{-# LANGUAGE TypeOperators, TypeFamilies, OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances, FlexibleInstances, ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}
{-# LANGUAGE CPP, DataKinds #-}
module Database.Selda.Table where
import Database.Selda.Types
import Database.Selda.SqlType
import Control.Exception hiding (TypeError)
import GHC.Exts
import GHC.TypeLits
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]}
type family NonNull a :: Constraint where
#if MIN_VERSION_base(4, 9, 0)
NonNull (Maybe a) = TypeError
( Text "Optional columns must not be nested, and" :<>:
Text " required or primary key columns" :$$:
Text "must not have option types."
)
#else
NonNull (Maybe a) = a ~ Maybe a
#endif
NonNull a = ()
data ColAttr = Primary | AutoIncrement | Required | Optional | Unique
deriving (Show, Eq, Ord)
required :: (SqlType a, NonNull a) => ColName -> ColSpec a
required = addAttr Required . newCol
optional :: (SqlType a, NonNull a) => ColName -> ColSpec (Maybe a)
optional = addAttr Optional . newCol
primary :: (SqlType a, 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 {-# OVERLAPPABLE #-} 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 = 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
]