{-# LANGUAGE UndecidableInstances #-}

-- | Defines a generic schema type that can be used to define schemas for Beam tables
module Database.Beam.Schema.Tables
    (
    -- * Database Types
      Database(..), GenDatabaseTable(..), DatabaseTable(..), DatabaseSettings(..)
    , ReifiedDatabaseSchema(..), ReifiedTableSchema(..)
    , autoDbSettings
    , allTableSettings

    , SqlValue'(..)
    , Lenses, LensFor(..)

    -- * Columnar and Column Tags
    , Columnar(..), Columnar'(..)
    , Nullable(..), TableField(..)
    , fieldName, fieldConstraints, fieldSchema, maybeFieldSchema

    , TableSettings(..)

    -- * Tables
    , Table(..), defTblFieldSettings
    , reifyTableSchema, tableValuesNeeded
    , pk
    , pkAllValues, fieldAllValues, pkChangeRep, changeRep
    , pkMakeSqlValues, makeSqlValues

    -- * Fields
    , HasDefaultFieldSchema(..), FieldSchema(..), FromSqlValuesM(..), FromSqlValues(..)
    , popSqlValue, peekSqlValue )
    where

import Database.Beam.SQL.Types

import Control.Arrow
import Control.Applicative
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.Error
import Control.Monad.Identity

import Data.Proxy
import Data.Coerce
import Data.Typeable
import Data.Text (Text)
import Data.List
import Data.Char
import Data.String
import Data.Void
import Data.Monoid
import qualified Data.Text as T

import Database.HDBC ( SqlColDesc(..), SqlValue(..), SqlTypeId(..)
                     , fromSql)

import GHC.Generics hiding (R)
import qualified GHC.Generics as Generic

import Lens.Micro hiding (to)

type ReifiedDatabaseSchema = [(Text, ReifiedTableSchema)]
type ReifiedTableSchema = [(Text, SQLColumnSchema)]

class Database db where
    allTables :: (forall tbl. Table tbl => f tbl -> b) -> db f -> [b]
    default allTables :: ( Generic (db f)
                         , GAllTables f (Rep (db f) ()) ) =>
                        (forall tbl. Table tbl => f tbl -> b) -> db f -> [b]
    allTables f db = allTables' f (from' db)

allTableSettings :: Database db => DatabaseSettings db -> [GenDatabaseTable db]
allTableSettings = allTables GenDatabaseTable

autoDbSettings :: ( Generic (DatabaseSettings db)
                  , GAutoDbSettings (Rep (DatabaseSettings db) ()) ) =>
                   DatabaseSettings db
autoDbSettings = to' autoDbSettings'

data GenDatabaseTable db where
    GenDatabaseTable :: DatabaseTable db table -> GenDatabaseTable db
data DatabaseTable (db :: ((((* -> *) -> *) -> *) -> *)) table where
    DatabaseTable :: Table table => Proxy table -> Text -> DatabaseTable db table

type DatabaseSettings db = db (DatabaseTable db)

class GAutoDbSettings x where
    autoDbSettings' :: x
instance GAutoDbSettings (x p) => GAutoDbSettings (D1 f x p) where
    autoDbSettings' = M1 autoDbSettings'
instance GAutoDbSettings (x p) => GAutoDbSettings (C1 f x p) where
    autoDbSettings' = M1 autoDbSettings'
instance (GAutoDbSettings (x p), GAutoDbSettings (y p)) => GAutoDbSettings ((x :*: y) p) where
    autoDbSettings' = autoDbSettings' :*: autoDbSettings'
instance (Table tbl, Selector f) => GAutoDbSettings (S1 f (K1 Generic.R (DatabaseTable db tbl)) p) where
    autoDbSettings' = M1 (K1 (DatabaseTable (Proxy :: Proxy tbl) (fromString name)))
        where name  = unCamelCaseSel (selName (undefined :: S1 f (K1 Generic.R (DatabaseTable db tbl)) p))

class GAllTables f x where
    allTables' :: (forall tbl. Table tbl => f tbl -> b) -> x -> [b]
instance GAllTables f (x p) => GAllTables f (M1 s m x p) where
    allTables' f (M1 x) = allTables' f x
instance (GAllTables f (x p), GAllTables f (y p)) => GAllTables f ((x :*: y) p) where
    allTables' f (x :*: y) = allTables' f x ++ allTables' f y
instance Table tbl => GAllTables f (K1 Generic.R (f tbl) p) where
    allTables' f (K1 x) = [f x]

data Lenses (t :: (* -> *) -> *) (f :: * -> *) x
data LensFor t x where
    LensFor :: Generic t => Lens' t x -> LensFor t x
newtype Exposed x = Exposed x
newtype SqlValue' x = SqlValue' SqlValue

-- | A type family that we use to "tag" columns in our table datatypes.
--
--   This is what allows us to use the same table type to hold table data, describe table settings,
--   derive lenses, and provide expressions.
--
--   The basic rules are
--
-- > Columnar Identity x = x
--
--   Thus, any Beam table applied to 'Identity' will yield a simplified version of the data type, that contains
--   just what you'd expect.
--
--   The 'Nullable' type is used when referencing 'PrimaryKey's that we want to include optionally.
--   For example, if we have a table with a 'PrimaryKey', like the following
--
-- > data BeamTableT f = BeamTableT
-- >                   { _refToAnotherTable :: PrimaryKey AnotherTableT f
-- >                   , ... }
--
--   we would typically be required to provide values for the 'PrimaryKey' embedded into 'BeamTableT'. We can use
--   'Nullable' to lift this constraint.
--
-- > data BeamTableT f = BeamTableT
-- >                   { _refToAnotherTable :: PrimaryKey AnotherTableT (Nullable f)
-- >                   , ... }
--
--   Now we can use 'justRef' and 'nothingRef' to refer to this table optionally. The embedded 'PrimaryKey' in '_refToAnotherTable'
--   automatically has its fields converted into 'Maybe' using 'Nullable'.
--
--   The last 'Columnar' rule is
--
-- > Columnar f x = f x
--
--   Use this rule if you'd like to parameterize your table type over any other functor. For example, this is used
--   in the query modules to write expressions such as 'TableT QExpr', which returns a table whose fields have been
--   turned into query expressions.
--
--   The other rules are used within Beam to provide lenses and to expose the inner structure of the data type.
type family Columnar (f :: * -> *) x where
    Columnar Exposed x = Exposed x

    Columnar Identity x = x

    Columnar (Lenses t Identity) x = LensFor (t Identity) (Columnar Identity x)
    Columnar (Lenses t f) x = LensFor (t f) (f x)

    Columnar (Nullable c) x = Columnar c (Maybe x)

    Columnar f x = f x

newtype Columnar' f a = Columnar' (Columnar f a)

-- | Support for NULLable Foreign Key references.
--
-- > data MyTable f = MyTable
-- >                { nullableRef :: PrimaryKey AnotherTable (Nullable f)
-- >                , ... }
-- >                 deriving (Generic, Typeable)
--
-- See 'Columnar' for more information.
data Nullable (c :: * -> *) x

-- | Metadata for a field of type 'ty' in 'table'.
--
-- > Columnar (TableField table) ty = TableField table ty
--
--   This is used to declare 'tblFieldSettings' in the 'Table' class.
--
--   It is easiest to access these fields through the lenses 'fieldName', 'fieldConstraints', and 'fieldSettings'.
--
-- > data EmployeeT f = Employee
-- >                  { _employeeId :: Columnar f AutoId
-- >                  , _employeeDepartment :: Columnar f Text
-- >                  , _employeeFirstName :: Columnar f Text
-- >                  , _employeeLastName :: Columnar f Text }
-- >                    deriving Generic
--
--   Now we can use 'tableConfigLenses' and the 'TableField' lenses to modify the default table configuration
--
-- > Employee (LensFor employeeIdC) (LensFor employeeDepartmentC) (LensFor employeeFirstNameC) (LensFor employeeLastNameC) = tableConfigLenses
-- >
-- > instance Table EmployeeT where
-- >    type PrimaryKey EmployeeT f = PK f AutoId
-- >    primaryKey = PK . _beamEmployeeId
-- >
-- >    tblFieldSettings = defTblFieldSettings
-- >                     & employeeFirstNameC . fieldName .~ "fname"
-- >                     & employeeLastNameC  . fieldName .~ "lname"
-- >                     & employeeLastNameC  . fieldSettings .~ Varchar (Just 128) -- Give it a 128 character limit
data TableField (table :: (* -> *) -> *) ty = TableField
                                            { _fieldName        :: Text             -- ^ The field name
                                            , _fieldConstraints :: [SQLConstraint]  -- ^ Constraints for the field (such as AutoIncrement, PrimaryKey, etc)
                                            , _fieldSchema      :: FieldSchema ty   -- ^ SQL storage informationa for the field
                                            }
deriving instance Show (TableField t ty)

fieldName :: Lens' (TableField table ty) Text
fieldName f (TableField name cs s) = (\name' -> TableField name' cs s) <$> f name
fieldConstraints :: Lens' (TableField table ty) [SQLConstraint]
fieldConstraints f (TableField name cs s) = (\cs' -> TableField name cs' s) <$> f cs
fieldSchema :: Lens (TableField table a) (TableField table b) (FieldSchema a) (FieldSchema b)
fieldSchema f (TableField name cs s) = (\s' -> TableField name cs s') <$> f s

type TableSettings table = table (TableField table)

from' :: Generic x => x -> Rep x ()
from' = from

to' :: Generic x => Rep x () -> x
to' = to

-- | The big Kahuna! All beam tables implement this class.
--
--   The kind of all table types is `(* -> *) -> *`. This is because all table types are actually /table type constructors/.
--   Every table type takes in another type constructor, called the /column tag/, and uses that constructor to instantiate the column types.
--   See the documentation for 'Columnar'. In order for the default deriving to work, every type passed into 'Columnar' must be an instance
--   of 'FieldSchema'.
--
--   This class is mostly Generic-derivable. You need only specify a type for the table's primary key and a method to extract the primary key
--   given the table.
--
--   Even though all methods are derivable, you are free to override them. Typically, you may want to override 'tblFieldSettings' if you want
--   to specify options for column storage or to rename columns. See 'TableField' for more information. You may want to use 'tableConfigLenses'
--   to simplify accessing 'tblFieldSettings'.
--
--   An example table:
--
-- > data BlogPostT f = BlogPost
-- >                  { _blogPostSlug    :: Columnar f Text
-- >                  , _blogPostBody    :: Columnar f Text
-- >                  , _blogPostDate    :: Columnar f UTCTime
-- >                  , _blogPostAuthor  :: PrimaryKey AuthorT f
-- >                  , _blogPostTagline :: Columnar f (Maybe Text)
-- >                  , _blogPostImageGallery :: PrimaryKey ImageGalleryT (Nullable f) }
-- >                    deriving Generic
-- > instance Table BlogPostT where
-- >    type PrimaryKey BlogPostT f = PK f Text
-- >    primaryKey = PK . _blogPostSlug
--
--   We can interpret this as follows:
--
--     * The `_blogPostSlug`, `_blogPostBody`, `_blogPostDate`, and `_blogPostTagline` fields are of types 'Text', 'Text', 'UTCTime', and 'Maybe Text' respectfully.
--     * Since `_blogPostSlug`, `_blogPostBody`, `_blogPostDate`, `_blogPostAuthor` must be provided (i.e, they cannot contain 'Nothing'), they will be given SQL NOT NULL constraints.
--       `_blogPostTagline` is declared 'Maybe' so 'Nothing' will be stored as NULL in the database. `_blogPostImageGallery` will be allowed to be empty because it uses the 'Nullable' tag modifier.
--     * `blogPostAuthor` references the `AuthorT` table (not given here) and is required.
--     * `blogPostImageGallery` references the `ImageGalleryT` table (not given here), but this relation is not required (i.e., it may be 'Nothing'. See 'Nullable').
class Typeable table  => Table (table :: (* -> *) -> *) where

    -- | A data type representing the types of primary keys for this table.
    --   In order to play nicely with the default deriving mechanism, this type must be an instance of 'Generic'.
    data PrimaryKey table (column :: * -> *) :: *

    -- | Given a table, this should return the PrimaryKey from the table. By keeping this polymorphic over column,
    --   we ensure that the primary key values come directly from the table (i.e., they can't be arbitrary constants)
    primaryKey :: table column -> PrimaryKey table column

    tblFieldSettings :: TableSettings table
    default tblFieldSettings :: ( Generic (TableSettings table)
                                , GDefaultTableFieldSettings (Rep (TableSettings table) ())) => TableSettings table
    tblFieldSettings = defTblFieldSettings

    zipTablesM :: Monad m => (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) -> table f -> table g -> m (table h)
    default zipTablesM :: ( GZipTables f g h (Rep (table Exposed)) (Rep (table f)) (Rep (table g)) (Rep (table h))
                         , Generic (table f), Generic (table g), Generic (table h) ) =>
                        Monad m => (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) -> table f -> table g -> m (table h)
    zipTablesM combine f g = do hRep <- gZipTables (Proxy :: Proxy (Rep (table Exposed))) combine (from' f) (from' g)
                                return (to' hRep)

    zipPkM :: Monad m => (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) -> PrimaryKey table f -> PrimaryKey table g -> m (PrimaryKey table h)
    default zipPkM :: ( GZipTables f g h (Rep (PrimaryKey table Exposed)) (Rep (PrimaryKey table f)) (Rep (PrimaryKey table g)) (Rep (PrimaryKey table h))
                      , Generic (PrimaryKey table f), Generic (PrimaryKey table g), Generic (PrimaryKey table h)
                      , Monad m) => (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) -> PrimaryKey table f -> PrimaryKey table g -> m (PrimaryKey table h)
    zipPkM combine f g = do hRep <- gZipTables (Proxy :: Proxy (Rep (PrimaryKey table Exposed))) combine (from' f) (from' g)
                            return (to' hRep)

reifyTableSchema :: Table table => Proxy table -> ReifiedTableSchema
reifyTableSchema (Proxy :: Proxy table) = fieldAllValues (\(Columnar' (TableField name constraints settings)) ->
                                                                  (name, fieldColDesc settings constraints)) (tblFieldSettings :: TableSettings table)

tableValuesNeeded :: Table table => Proxy table -> Int
tableValuesNeeded (Proxy :: Proxy table) = length (fieldAllValues (const ()) (tblFieldSettings :: TableSettings table))

pkAllValues :: Table t => (forall a. Columnar' f a -> b) -> PrimaryKey t f -> [b]
pkAllValues (f :: forall a. Columnar' f a -> b) (pk :: PrimaryKey table f) = execWriter (zipPkM combine pk pk)
    where combine :: Columnar' f a -> Columnar' f a -> Writer [b] (Columnar' f a)
          combine x _ = do tell [f x]
                           return x

fieldAllValues :: Table t => (forall a. Columnar' f a -> b) -> t f -> [b]
fieldAllValues  (f :: forall a. Columnar' f a -> b) (tbl :: table f) = execWriter (zipTablesM combine tbl tbl)
    where combine :: Columnar' f a -> Columnar' f a -> Writer [b] (Columnar' f a)
          combine x _ = do tell [f x]
                           return x

pkChangeRep :: Table t => (forall a. Columnar' f a -> Columnar' g a) -> PrimaryKey t f -> PrimaryKey t g
pkChangeRep f pk = runIdentity (zipPkM (\x _ -> return (f x))  pk pk)

changeRep :: Table t => (forall a. Columnar' f a -> Columnar' g a) -> t f -> t g
changeRep f tbl = runIdentity (zipTablesM (\x _ -> return (f x)) tbl tbl)

pkMakeSqlValues :: Table t => PrimaryKey t Identity -> PrimaryKey t SqlValue'
pkMakeSqlValues pk = runIdentity (zipPkM (\(Columnar' x) (Columnar' tf) -> return (Columnar' (SqlValue' (fsMakeSqlValue (_fieldSchema tf) x)))) pk (primaryKey tblFieldSettings))

makeSqlValues :: Table t => t Identity -> t SqlValue'
makeSqlValues tbl = runIdentity (zipTablesM (\(Columnar' x) (Columnar' tf) -> return (Columnar' (SqlValue' (fsMakeSqlValue (_fieldSchema tf) x)))) tbl tblFieldSettings)

-- | Synonym for 'primaryKey'
pk :: Table t => t f -> PrimaryKey t f
pk = primaryKey

instance FromSqlValues t => FromSqlValues (Maybe t) where
    valuesNeeded (_ :: Proxy (Maybe t)) = valuesNeeded (Proxy :: Proxy t)
    fromSqlValues' = mfix $ \(_ :: Maybe t) ->
                     do values <- get
                        let colCount = valuesNeeded (Proxy :: Proxy t)
                            colValues = take colCount values
                        if all (==SqlNull) colValues
                        then put (drop colCount values) >> return Nothing
                        else Just <$> fromSqlValues'

defTblFieldSettings :: ( Generic (TableSettings table)
                       ,  GDefaultTableFieldSettings (Rep (TableSettings table) ())) =>
                       TableSettings table
defTblFieldSettings = withProxy $ \proxy -> to' (gDefTblFieldSettings proxy)
    where withProxy :: (Proxy (Rep (TableSettings table) ()) -> TableSettings table) -> TableSettings table
          withProxy f = f Proxy

fieldColDesc :: FieldSchema fs -> [SQLConstraint] -> SQLColumnSchema
fieldColDesc schema cs = let base = fsColDesc schema
                         in base { csConstraints = csConstraints base ++ cs }

class GZipTables f g h (exposedRep :: * -> *) fRep gRep hRep where
    gZipTables :: Monad m => Proxy exposedRep -> (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) -> fRep () -> gRep () -> m (hRep ())
instance ( GZipTables f g h exp1 f1 g1 h1
         , GZipTables f g h exp2 f2 g2 h2) =>
    GZipTables f g h (exp1 :*: exp2) (f1 :*: f2) (g1 :*: g2) (h1 :*: h2) where

        gZipTables _ combine (f1 :*: f2) (g1 :*: g2) =
            do h1 <- gZipTables (Proxy :: Proxy exp1) combine f1 g1
               h2 <- gZipTables (Proxy :: Proxy exp2) combine f2 g2
               return (h1 :*: h2)
instance GZipTables f g h exp fRep gRep hRep =>
    GZipTables f g h (M1 x y exp) (M1 x y fRep) (M1 x y gRep) (M1 x y hRep) where
        gZipTables _ combine (M1 f) (M1 g) = do h <- gZipTables (Proxy :: Proxy exp) combine f g
                                                return (M1 h)
instance ( fa ~ Columnar f a
         , ga ~ Columnar g a
         , ha ~ Columnar h a) =>
    GZipTables f g h (K1 Generic.R (Exposed a)) (K1 Generic.R fa) (K1 Generic.R ga) (K1 Generic.R ha) where
        gZipTables _ combine (K1 f) (K1 g) = do Columnar' h <- combine (Columnar' f :: Columnar' f a) (Columnar' g :: Columnar' g a)
                                                return (K1 (h :: Columnar h a))
instance ( Generic (PrimaryKey rel f)
         , Generic (PrimaryKey rel g)
         , Generic (PrimaryKey rel h)

         , GZipTables f g h (Rep (PrimaryKey rel Exposed)) (Rep (PrimaryKey rel f)) (Rep (PrimaryKey rel g)) (Rep (PrimaryKey rel h))) =>
    GZipTables f g h (K1 Generic.R (PrimaryKey rel Exposed)) (K1 Generic.R (PrimaryKey rel f)) (K1 Generic.R (PrimaryKey rel g)) (K1 Generic.R (PrimaryKey rel h)) where
    gZipTables _ combine (K1 f) (K1 g) = do hRep <- gZipTables (Proxy :: Proxy (Rep (PrimaryKey rel Exposed))) combine (from' f) (from' g)
                                            return (K1 (to' hRep))

instance  ( Generic (PrimaryKey rel (Nullable f))
          , Generic (PrimaryKey rel (Nullable g))
          , Generic (PrimaryKey rel (Nullable h))

          , GZipTables f g h (Rep (PrimaryKey rel (Nullable Exposed))) (Rep (PrimaryKey rel (Nullable f))) (Rep (PrimaryKey rel (Nullable g))) (Rep (PrimaryKey rel (Nullable h)))) =>
         GZipTables f g h
                    (K1 Generic.R (PrimaryKey rel (Nullable Exposed)))
                    (K1 Generic.R (PrimaryKey rel (Nullable f)))
                    (K1 Generic.R (PrimaryKey rel (Nullable g)))
                    (K1 Generic.R (PrimaryKey rel (Nullable h))) where
    gZipTables _ combine (K1 f) (K1 g) = do hRep <- gZipTables (Proxy :: Proxy (Rep (PrimaryKey rel (Nullable Exposed)))) combine (from' f) (from' g)
                                            return (K1 (to' hRep))

class GDefaultTableFieldSettings x where
    gDefTblFieldSettings :: Proxy x -> x
instance GDefaultTableFieldSettings (p x) => GDefaultTableFieldSettings (D1 f p x) where
    gDefTblFieldSettings (_ :: Proxy (D1 f p x)) = M1 $ gDefTblFieldSettings (Proxy :: Proxy (p x))
instance GDefaultTableFieldSettings (p x) => GDefaultTableFieldSettings (C1 f p x) where
    gDefTblFieldSettings (_ :: Proxy (C1 f p x)) = M1 $ gDefTblFieldSettings (Proxy :: Proxy (p x))
instance (GDefaultTableFieldSettings (a p), GDefaultTableFieldSettings (b p)) => GDefaultTableFieldSettings ((a :*: b) p) where
    gDefTblFieldSettings (_ :: Proxy ((a :*: b) p)) = gDefTblFieldSettings (Proxy :: Proxy (a p)) :*: gDefTblFieldSettings (Proxy :: Proxy (b p))

instance (Table table, HasDefaultFieldSchema field, Selector f ) =>
    GDefaultTableFieldSettings (S1 f (K1 Generic.R (TableField table field)) p) where
    gDefTblFieldSettings (_ :: Proxy (S1 f (K1 Generic.R (TableField table field)) p)) = M1 (K1 s)
        where s = TableField (T.pack name) [] defFieldSchema
              name = unCamelCaseSel (selName (undefined :: S1 f (K1 Generic.R (TableField table field)) ()))

instance ( Table table, Table related
         , Selector f

         , Generic (PrimaryKey related (TableField related))
         , Generic (PrimaryKey related (TableField table))
         , GZipTables (TableField related) (TableField related) (TableField table)
                      (Rep (PrimaryKey related Exposed))
                      (Rep (PrimaryKey related (TableField related))) (Rep (PrimaryKey related (TableField related))) (Rep (PrimaryKey related (TableField table))) ) =>
    GDefaultTableFieldSettings (S1 f (K1 Generic.R (PrimaryKey related (TableField table))) p) where

    gDefTblFieldSettings _ = M1 . K1 $ primaryKeySettings'
        where tableSettings = tblFieldSettings :: TableSettings related
              primaryKeySettings :: PrimaryKey related (TableField related)
              primaryKeySettings = primaryKey tableSettings

              primaryKeySettings' :: PrimaryKey related (TableField table)
              primaryKeySettings' = to' (runIdentity (gZipTables (Proxy :: Proxy (Rep (PrimaryKey related Exposed))) convertToForeignKeyField (from' primaryKeySettings) (from' primaryKeySettings)))

              convertToForeignKeyField :: Columnar' (TableField related) c -> Columnar' (TableField related) c -> Identity (Columnar' (TableField table) c)
              convertToForeignKeyField (Columnar' tf) _ =
                  pure . Columnar' $
                  tf { _fieldName = keyName <> "__" <> _fieldName tf
                     , _fieldConstraints = removeConstraints (_fieldConstraints tf) }


              removeConstraints = filter (\x -> x /= SQLPrimaryKey && x /= SQLAutoIncrement)

              keyName = T.pack (unCamelCaseSel (selName (undefined :: S1 f (K1 Generic.R (PrimaryKey related (TableField table))) ())))

instance ( Table table, Table related
         , Selector f

         , Generic (PrimaryKey related (TableField related))
         , Generic (PrimaryKey related (TableField table))
         , Generic (PrimaryKey related (Nullable (TableField table)))
         , GZipTables (TableField table) (TableField table) (Nullable (TableField table))
                      (Rep (PrimaryKey related Exposed))
                      (Rep (PrimaryKey related (TableField table)))
                      (Rep (PrimaryKey related (TableField table)))
                      (Rep (PrimaryKey related (Nullable (TableField table))))
         , GZipTables (TableField related) (TableField related) (TableField table)
                      (Rep (PrimaryKey related Exposed))
                      (Rep (PrimaryKey related (TableField related)))
                      (Rep (PrimaryKey related (TableField related)))
                      (Rep (PrimaryKey related (TableField table)))) =>
    GDefaultTableFieldSettings (S1 f (K1 Generic.R (PrimaryKey related (Nullable (TableField table)))) p) where

    gDefTblFieldSettings _ =
        M1 . K1 $ settings
        where M1 (K1 nonNullSettings) = gDefTblFieldSettings (Proxy :: Proxy (S1 f (K1 Generic.R (PrimaryKey related (TableField table))) p))
              nonNullSettingsRep = from' nonNullSettings :: Rep (PrimaryKey related (TableField table)) ()

              settings :: PrimaryKey related (Nullable (TableField table))
              settings = to' (runIdentity (gZipTables (Proxy :: Proxy (Rep (PrimaryKey related Exposed))) removeNotNullConstraints nonNullSettingsRep nonNullSettingsRep))

              removeNotNullConstraints :: Columnar' (TableField table) ty -> Columnar' (TableField table) ty -> Identity (Columnar' (Nullable (TableField table)) ty)
              removeNotNullConstraints (Columnar' tf) _ =
                  pure . Columnar' $
                  tf { _fieldSchema = maybeFieldSchema (_fieldSchema tf) }

data FieldSchema ty = FieldSchema
                    { fsColDesc :: SQLColumnSchema
                    , fsHumanReadable :: String
                    , fsMakeSqlValue :: ty -> SqlValue
                    , fsFromSqlValue :: FromSqlValuesM ty }
instance Show (FieldSchema ty) where
    show (FieldSchema desc hr _ _) = concat ["FieldSchema (", show desc, ") (", show hr, ") _ _"]

-- | Type class for types which can construct a default 'TableField' given a column name.
class HasDefaultFieldSchema fs where
    defFieldSchema :: FieldSchema fs

type FromSqlValuesM a = ErrorT String (State [SqlValue]) a
popSqlValue, peekSqlValue :: FromSqlValuesM SqlValue
popSqlValue = do st <- get
                 put (tail st)
                 return (head st)
peekSqlValue = head <$> get
class FromSqlValues a where
    fromSqlValues' :: FromSqlValuesM a
    valuesNeeded :: Proxy a -> Int
    valuesNeeded _ = 1

    default fromSqlValues' :: HasDefaultFieldSchema a => FromSqlValuesM a
    fromSqlValues' = fsFromSqlValue defFieldSchema
instance Table tbl => FromSqlValues (tbl Identity) where
    fromSqlValues' = zipTablesM combine settings settings
        where settings :: TableSettings tbl
              settings = tblFieldSettings

              combine (Columnar' tf) x = Columnar' <$> fsFromSqlValue (_fieldSchema tf)
    valuesNeeded _ = tableValuesNeeded (Proxy :: Proxy tbl)
instance (FromSqlValues a, FromSqlValues b) => FromSqlValues (a, b) where
    fromSqlValues' = (,) <$> fromSqlValues' <*> fromSqlValues'
    valuesNeeded _ = valuesNeeded (Proxy :: Proxy a) + valuesNeeded (Proxy :: Proxy b)
instance (FromSqlValues a, FromSqlValues b, FromSqlValues c) => FromSqlValues (a, b, c) where
    fromSqlValues' = (,,) <$> fromSqlValues' <*> fromSqlValues' <*> fromSqlValues'
    valuesNeeded _ = valuesNeeded (Proxy :: Proxy a) + valuesNeeded (Proxy :: Proxy b) + valuesNeeded (Proxy :: Proxy c)
instance (FromSqlValues a, FromSqlValues b, FromSqlValues c, FromSqlValues d) => FromSqlValues (a, b, c, d) where
    fromSqlValues' = (,,,) <$> fromSqlValues' <*> fromSqlValues' <*> fromSqlValues' <*> fromSqlValues'
    valuesNeeded _ = valuesNeeded (Proxy :: Proxy a) + valuesNeeded (Proxy :: Proxy b) + valuesNeeded (Proxy :: Proxy c) + valuesNeeded (Proxy :: Proxy d)
instance (FromSqlValues a, FromSqlValues b, FromSqlValues c, FromSqlValues d, FromSqlValues e) => FromSqlValues (a, b, c, d, e) where
    fromSqlValues' = (,,,,) <$> fromSqlValues' <*> fromSqlValues' <*> fromSqlValues' <*> fromSqlValues' <*> fromSqlValues'
    valuesNeeded _ = valuesNeeded (Proxy :: Proxy a) + valuesNeeded (Proxy :: Proxy b) + valuesNeeded (Proxy :: Proxy c) + valuesNeeded (Proxy :: Proxy d) + valuesNeeded (Proxy :: Proxy e)

-- Internal functions

unCamelCase :: String -> [String]
unCamelCase "" = []
unCamelCase s
    | (comp@(_:_), next) <- break isUpper s =
          let next' = case next of
                        [] -> []
                        x:xs -> toLower x:xs
          in map toLower comp:unCamelCase next'
    | otherwise =
        let (comp@(_:_), next) = span isUpper s
            next' = case next of
                      [] -> []
                      x:xs -> toLower x:xs
        in map toLower comp:unCamelCase next'

unCamelCaseSel :: String -> String
unCamelCaseSel ('_':xs) = unCamelCaseSel xs
unCamelCaseSel xs = case unCamelCase xs of
                      [xs] -> xs
                      _:xs -> intercalate "_" xs

maybeFieldSchema :: FieldSchema ty -> FieldSchema (Maybe ty)
maybeFieldSchema base = let SQLColumnSchema desc constraints =  fsColDesc base
                            in FieldSchema
                               { fsColDesc = SQLColumnSchema desc (filter (/=SQLNotNull) constraints)
                               , fsHumanReadable = "maybeFieldSchema (" ++ fsHumanReadable base ++ ")"
                               , fsMakeSqlValue = \x ->
                                                  case x of
                                                    Nothing -> SqlNull
                                                    Just x -> fsMakeSqlValue base x
                               , fsFromSqlValue = do val <- peekSqlValue
                                                     case val of
                                                       SqlNull -> Nothing <$ popSqlValue
                                                       val -> Just <$> fsFromSqlValue base }