{-# 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)

-- | A non-empty list of selectors, where the element selectors need not have
--   the same type. Used to specify constraints, such as uniqueness or primary
--   key, potentially spanning multiple columns.
data Group t a where
  (:+)   :: Selector t a -> Group t b -> Group t (a :*: b)
  Single :: Selector t a -> Group t a
infixr 1 :+

-- | A generic column attribute.
--   Essentially a pair or a record selector over the type @a@ and a column
--   attribute. An attribute may be either a 'Group' attribute, meaning that
--   it can span multiple columns, or a 'Selector' -- single column -- attribute.
data Attr a where
  (:-) :: SelectorLike g => g t a -> Attribute g t a -> Attr t
infixl 0 :-

-- | Generate a table from the given table name and list of column attributes.
--   All @Maybe@ fields in the table's type will be represented by nullable
--   columns, and all non-@Maybe@ fields fill be represented by required
--   columns.
--   For example:
--
-- > data Person = Person
-- >   { id   :: ID Person
-- >   , name :: Text
-- >   , age  :: Int
-- >   , pet  :: Maybe Text
-- >   }
-- >   deriving Generic
-- >
-- > people :: Table Person
-- > people = table "people" [#id :- autoPrimary]
--
--   This will result in a table of @Person@s, with an auto-incrementing primary
--   key.
--
--   If the given type does not have record selectors, the column names will be
--   @col_1@, @col_2@, etc.
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

-- | Generate a table from the given table name,
--   a list of column attributes and a function
--   that maps from field names to column names.
--   Ex.:
--
-- > data Person = Person
-- >   { personId   :: Int
-- >   , personName :: Text
-- >   , personAge  :: Int
-- >   , personPet  :: Maybe Text
-- >   }
-- >   deriving Generic
-- >
-- > people :: Table Person
-- > people = tableFieldMod "people"
-- >   [#personName :- autoPrimaryGen]
-- >   (fromJust . stripPrefix "person")
--
--   This will create a table with the columns named
--   @Id@, @Name@, @Age@ and @Pet@.
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]

-- | Remove duplicate attributes.
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}

-- | Some attribute that may be set on a column of type @c@, in a table of
--   type @t@.
data Attribute (g :: * -> * -> *) t c
  = Attribute [ColAttr]
  | ForeignKey (Table (), ColName)

-- | A primary key which does not auto-increment.
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]

-- | Create an index on these column(s).
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]

-- | Create an index using the given index method on this column.
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)]

-- | An auto-incrementing primary key.
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]

-- | A "weakly auto-incrementing" primary key.
--   Behaves like 'autoPrimary', but the sequence of generated keys is not
--   guaranteed to be monotonically increasing.
--
--   This gives better performance on some backends, but means that
--   the relation @a > b <=> a was inserted at a later point in time than b@
--   does not hold.
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]

-- | An untyped auto-incrementing primary key.
--   You should really only use this for ad hoc tables, such as tuples.
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]

-- | Like 'weakAutoPrimary', but for untyped IDs.
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]

-- | A table-unique value.
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
  -- | A foreign key constraint referencing the given table and column.
  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

-- | An expression representing the given table.
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