{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}

-- | Intended for creating new backends.
module Database.Persist.Sql.Internal
    ( mkColumns
    , defaultAttribute
    , BackendSpecificOverrides(..)
    , getBackendSpecificForeignKeyName
    , setBackendSpecificForeignKeyName
    , emptyBackendSpecificOverrides
    ) where

import Control.Applicative ((<|>))
import Data.Monoid (mappend, mconcat)
import Data.Text (Text)
import qualified Data.Text as T

import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Database.Persist.EntityDef
import Database.Persist.Quasi
import Database.Persist.Sql.Types
import Database.Persist.Types

-- | Record of functions to override the default behavior in 'mkColumns'.  It is
-- recommended you initialize this with 'emptyBackendSpecificOverrides' and
-- override the default values, so that as new fields are added, your code still
-- compiles.
--
-- For added safety, use the @getBackendSpecific*@ and @setBackendSpecific*@
-- functions, as a breaking change to the record field labels won't be reflected
-- in a major version bump of the library.
--
-- @since 2.11
data BackendSpecificOverrides = BackendSpecificOverrides
    { backendSpecificForeignKeyName :: Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB)
    }

-- | If the override is defined, then this returns a function that accepts an
-- entity name and field name and provides the 'ConstraintNameDB' for the
-- foreign key constraint.
--
-- An abstract accessor for the 'BackendSpecificOverrides'
--
-- @since 2.13.0.0
getBackendSpecificForeignKeyName
    :: BackendSpecificOverrides
    -> Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB)
getBackendSpecificForeignKeyName =
    backendSpecificForeignKeyName

-- | Set the backend's foreign key generation function to this value.
--
-- @since 2.13.0.0
setBackendSpecificForeignKeyName
    :: (EntityNameDB -> FieldNameDB -> ConstraintNameDB)
    -> BackendSpecificOverrides
    -> BackendSpecificOverrides
setBackendSpecificForeignKeyName func bso =
    bso { backendSpecificForeignKeyName = Just func }

findMaybe :: (a -> Maybe b) -> [a] -> Maybe b
findMaybe p = listToMaybe . mapMaybe p

-- | Creates an empty 'BackendSpecificOverrides' (i.e. use the default behavior; no overrides)
--
-- @since 2.11
emptyBackendSpecificOverrides :: BackendSpecificOverrides
emptyBackendSpecificOverrides = BackendSpecificOverrides Nothing

defaultAttribute :: [FieldAttr] -> Maybe Text
defaultAttribute = findMaybe $ \case
    FieldAttrDefault x -> Just x
    _ -> Nothing

-- | Create the list of columns for the given entity.
mkColumns
    :: [EntityDef]
    -> EntityDef
    -> BackendSpecificOverrides
    -> ([Column], [UniqueDef], [ForeignDef])
mkColumns allDefs t overrides =
    (cols, getEntityUniques t, getEntityForeignDefs t)
  where
    cols :: [Column]
    cols = map goId idCol `mappend` map go (getEntityFieldsDatabase t)

    idCol :: [FieldDef]
    idCol =
        case getEntityId t of
            EntityIdNaturalKey _ ->
                []
            EntityIdField fd ->
                [fd]

    goId :: FieldDef -> Column
    goId fd =
        Column
            { cName = fieldDB fd
            , cNull = False
            , cSqlType = fieldSqlType fd
            , cDefault =
                case defaultAttribute $ fieldAttrs fd of
                    Nothing ->
                        -- So this is not necessarily a problem...
                        -- because you can use eg `inserKey` to insert
                        -- a value into the database without ever asking
                        -- for a default attribute.
                        Nothing
                        -- But we need to be able to say "Hey, if this is
                        -- an *auto generated ID column*, then I need to
                        -- specify that it has the default serial picking
                        -- behavior for whatever SQL backend this is using.
                        -- Because naturally MySQL, Postgres, MSSQL, etc
                        -- all do ths differently, sigh.
                        -- Really, this should be something like,
                        --
                        -- > data ColumnDefault
                        -- >     = Custom Text
                        -- >     | AutogenerateId
                        -- >     | NoDefault
                        --
                        -- where Autogenerated is determined by the
                        -- MkPersistSettings.
                    Just def ->
                        Just def

            , cGenerated = fieldGenerated fd
            , cDefaultConstraintName =  Nothing
            , cMaxLen = maxLen $ fieldAttrs fd
            , cReference = mkColumnReference fd
            }

    tableName :: EntityNameDB
    tableName = getEntityDBName t

    go :: FieldDef -> Column
    go fd =
        Column
            { cName = fieldDB fd
            , cNull = nullable (fieldAttrs fd) /= NotNullable || isEntitySum t
            , cSqlType = fieldSqlType fd
            , cDefault = defaultAttribute $ fieldAttrs fd
            , cGenerated = fieldGenerated fd
            , cDefaultConstraintName =  Nothing
            , cMaxLen = maxLen $ fieldAttrs fd
            , cReference = mkColumnReference fd
            }

    maxLen :: [FieldAttr] -> Maybe Integer
    maxLen = findMaybe $ \case
        FieldAttrMaxlen n -> Just n
        _ -> Nothing

    refNameFn = fromMaybe refName (backendSpecificForeignKeyName overrides)

    mkColumnReference :: FieldDef -> Maybe ColumnReference
    mkColumnReference fd =
        fmap
            (\(tName, cName) ->
                ColumnReference tName cName $ overrideNothings $ fieldCascade fd
            )
        $ ref (fieldDB fd) (fieldReference fd) (fieldAttrs fd)

    -- a 'Nothing' in the definition means that the QQ migration doesn't
    -- specify behavior. the default is RESTRICT. setting this here
    -- explicitly makes migrations run smoother.
    overrideNothings (FieldCascade { fcOnUpdate = upd, fcOnDelete = del }) =
        FieldCascade
            { fcOnUpdate = upd <|> Just Restrict
            , fcOnDelete = del <|> Just Restrict
            }

    ref :: FieldNameDB
        -> ReferenceDef
        -> [FieldAttr]
        -> Maybe (EntityNameDB, ConstraintNameDB) -- table name, constraint name
    ref c fe []
        | ForeignRef f <- fe =
            Just (resolveTableName allDefs f, refNameFn tableName c)
        | otherwise = Nothing
    ref _ _ (FieldAttrNoreference:_) = Nothing
    ref c fe (a:as) = case a of
        FieldAttrReference x -> do
            (_, constraintName) <- ref c fe as
            pure (EntityNameDB  x, constraintName)
        FieldAttrConstraint x -> do
            (tableName_, _) <- ref c fe as
            pure (tableName_, ConstraintNameDB x)
        _ -> ref c fe as

refName :: EntityNameDB -> FieldNameDB -> ConstraintNameDB
refName (EntityNameDB table) (FieldNameDB column) =
    ConstraintNameDB $ Data.Monoid.mconcat [table, "_", column, "_fkey"]

resolveTableName :: [EntityDef] -> EntityNameHS -> EntityNameDB
resolveTableName [] (EntityNameHS t) = error $ "Table not found: " `Data.Monoid.mappend` T.unpack t
resolveTableName (e:es) hn
    | getEntityHaskellName e == hn = getEntityDBName e
    | otherwise = resolveTableName es hn