module Database.Selda.Table where
import Database.Selda.Types
import Database.Selda.SqlType
import Data.Text (Text, unpack, intercalate)
import Data.Proxy
import Data.List (sort, group)
import Data.Monoid
type family a :+++: b where
(a :*: b) :+++: c = a :*: (b :+++: c)
a :+++: b = a :*: b
infixr 5 :+++:
infixr 5 +++
class ComposeSpec t a b where
(+++) :: t a -> t b -> ColSpec (a :+++: b)
instance (ComposeSpec Table a b, ComposeSpec Table b c) =>
ComposeSpec Table (a :*: b) c where
a +++ b = ColSpec $ tableCols a ++ tableCols b
instance ((a :+++: b) ~ (a :*: b)) =>
ComposeSpec Table a b where
a +++ b = ColSpec $ tableCols a ++ tableCols b
instance (ComposeSpec ColSpec a b, ComposeSpec ColSpec b c) =>
ComposeSpec ColSpec (a :*: b) c where
ColSpec a +++ ColSpec b = ColSpec $ a ++ b
instance ((a :+++: b) ~ (a :*: b)) =>
ComposeSpec ColSpec a b where
ColSpec a +++ ColSpec b = ColSpec $ a ++ b
data Table a = Table
{
tableName :: !TableName
, tableCols :: ![ColInfo]
}
data ColInfo = ColInfo
{ colName :: !ColName
, colType :: !Text
, colAttrs :: ![ColAttr]
}
newCol :: forall a. SqlType a => ColName -> ColSpec a
newCol name = ColSpec [ColInfo
{ colName = name
, colType = sqlType (Proxy :: Proxy a)
, colAttrs = []
}]
newtype ColSpec a = ColSpec [ColInfo]
(¤) :: ColSpec a -> ColSpec b -> ColSpec (a :*: b)
ColSpec a ¤ ColSpec b = ColSpec (a ++ b)
infixr 1 ¤
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
deriving (Show, Eq, Ord)
required :: NonNull a => ColName -> ColSpec a
required = addAttr Required . newCol
optional :: SqlType a => ColName -> ColSpec (Maybe a)
optional = addAttr Optional . newCol
primary :: NonNull a => ColName -> ColSpec a
primary = addAttr Primary . required
autoPrimary :: ColName -> ColSpec Int
autoPrimary n = ColSpec [c {colAttrs = [Primary, AutoIncrement, Required]}]
where ColSpec [c] = newCol n :: ColSpec Int
addAttr :: SqlType a => ColAttr -> ColSpec a -> ColSpec a
addAttr attr (ColSpec [ci]) = ColSpec [ci {colAttrs = attr : colAttrs ci}]
addAttr _ _ = error "impossible: SqlType ColSpec with several columns"
table :: TableName -> ColSpec a -> Table a
table name (ColSpec cs) = Table
{ tableName = name
, tableCols = validate name $ map tidy 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 = error $ concat
[ "validation of table ", unpack name, " failed:"
, "\n "
, unpack $ intercalate "\n " errs
]
where
errs = concat
[ dupes
, pkDupes
, optionalRequiredMutex
]
dupes =
["duplicate column: " <> x | (x:_:_) <- soup $ map colName cis]
pkDupes =
["multiple primary keys" | (Primary:_:_) <- soup $ concatMap colAttrs cis]
optionalRequiredMutex =
[ "BUG: column " <> colName ci <> " is both optional and required"
| ci <- cis
, Optional `elem` colAttrs ci && Required `elem` colAttrs ci
]