{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeInType #-}

-- | WARNING: This is an @Internal@ module. As such, breaking changes to the API
-- of this module will not have a corresponding major version bump.
--
-- Please depend on "Database.Persist.ImplicitIdDef" instead. If you can't use
-- that module, please file an issue on GitHub with your desired use case.
--
-- @since 2.13.0.0
module Database.Persist.ImplicitIdDef.Internal where

import Data.Proxy
import Data.Text (Text)
import qualified Data.Text as Text
import Language.Haskell.TH (Type)
import LiftType
import Type.Reflection
import Data.Typeable (eqT)
import Data.Foldable (asum)

import Database.Persist.Class.PersistField (PersistField)
import Database.Persist.Names
import Database.Persist.Sql.Class
import Database.Persist.Types

-- | A specification for how the implied ID columns are created.
--
-- By default, @persistent@ will give each table a default column named @id@
-- (customizable by 'PersistSettings'), and the column type will be whatever
-- you'd expect from @'BackendKey' yourBackendType@. For The 'SqlBackend' type,
-- this is an auto incrementing integer primary key.
--
-- You might want to give a different example. A common use case in postgresql
-- is to use the UUID type, and automatically generate them using a SQL
-- function.
--
-- Previously, you'd need to add a custom @Id@ annotation for each model.
--
-- > User
-- >     Id   UUID default="uuid_generate_v1mc()"
-- >     name Text
-- >
-- > Dog
-- >     Id   UUID default="uuid_generate_v1mc()"
-- >     name Text
-- >     user UserId
--
-- Now, you can simply create an 'ImplicitIdDef' that corresponds to this
-- declaration.
--
-- @
-- newtype UUID = UUID 'ByteString'
--
-- instance 'PersistField' UUID where
--     'toPersistValue' (UUID bs) =
--         'PersistLiteral_' 'Escaped' bs
--     'fromPersistValue' pv =
--         case pv of
--             PersistLiteral_ Escaped bs ->
--                 Right (UUID bs)
--             _ ->
--                 Left "nope"
--
-- instance 'PersistFieldSql' UUID where
--     'sqlType' _ = 'SqlOther' "UUID"
-- @
--
-- With this instance at the ready, we can now create our implicit definition:
--
-- @
-- uuidDef :: ImplicitIdDef
-- uuidDef = mkImplicitIdDef \@UUID "uuid_generate_v1mc()"
-- @
--
-- And we can use 'setImplicitIdDef' to use this with the 'MkPersistSettings'
-- for our block.
--
-- @
-- mkPersist (setImplicitIdDef uuidDef sqlSettings) [persistLowerCase| ... |]
-- @
--
-- TODO: either explain interaction with mkMigrate or fix it. see issue #1249
-- for more details.
--
-- @since 2.13.0.0
data ImplicitIdDef = ImplicitIdDef
    { ImplicitIdDef -> EntityNameHS -> FieldType
iidFieldType :: EntityNameHS -> FieldType
    -- ^ The field type. Accepts the 'EntityNameHS' if you want to refer to it.
    -- By default, @Id@ is appended to the end of the Haskell name.
    --
    -- @since 2.13.0.0
    , ImplicitIdDef -> SqlType
iidFieldSqlType :: SqlType
    -- ^ The 'SqlType' for the default column. By default, this is 'SqlInt64' to
    -- correspond with an autoincrementing integer primary key.
    --
    -- @since 2.13.0.0
    , ImplicitIdDef -> Bool -> Type -> Type
iidType :: Bool -> Type -> Type
    -- ^ The Bool argument is whether or not the 'MkPersistBackend' type has the
    -- 'mpsGeneric' field set.
    --
    -- The 'Type' is the 'mpsBackend' value.
    --
    -- The default uses @'BackendKey' 'SqlBackend'@ (or a generic equivalent).
    --
    -- @since 2.13.0.0
    , ImplicitIdDef -> Maybe Text
iidDefault :: Maybe Text
    -- ^ The default expression for the field. Note that setting this to
    -- 'Nothing' is unsafe. see
    -- https://github.com/yesodweb/persistent/issues/1247 for more information.
    --
    -- With some cases - like the Postgresql @SERIAL@ type - this is safe, since
    -- there's an implied default.
    --
    -- @since 2.13.0.0
    , ImplicitIdDef -> Maybe Integer
iidMaxLen :: Maybe Integer
    -- ^ Specify the maximum length for a key column. This is necessary for
    -- @VARCHAR@ columns, like @UUID@ in MySQL. MySQL will throw a runtime error
    -- if a text or binary column is used in an index without a length
    -- specification.
    --
    -- @since 2.13.0.0
    }

-- | Create an 'ImplicitIdDef' based on the 'Typeable' and 'PersistFieldSql'
-- constraints in scope.
--
-- This function uses the @TypeApplications@ syntax.  Let's look at an example
-- that works with Postgres UUIDs.
--
-- > newtype UUID = UUID Text
-- >     deriving newtype PersistField
-- >
-- > instance PersistFieldSql UUID where
-- >     sqlType _ = SqlOther "UUID"
-- >
-- > idDef :: ImplicitIdDef
-- > idDef = mkImplicitIdDefTypeable @UUID "uuid_generate_v1mc()"
--
-- This 'ImplicitIdDef' will generate default UUID columns, and the database
-- will call the @uuid_generate_v1mc()@  function to generate the value for new
-- rows being inserted.
--
-- If the type @t@ is 'Text' or 'String' then a @max_len@ attribute of 200 is
-- set. To customize this, use 'setImplicitIdDefMaxLen'.
--
-- @since 2.13.0.0
mkImplicitIdDef
    :: forall t. (Typeable t, PersistFieldSql t)
    => Text
    -- ^ The default expression to use for columns. Should be valid SQL in the
    -- language you're using.
    -> ImplicitIdDef
mkImplicitIdDef :: Text -> ImplicitIdDef
mkImplicitIdDef Text
def =
    ImplicitIdDef :: (EntityNameHS -> FieldType)
-> SqlType
-> (Bool -> Type -> Type)
-> Maybe Text
-> Maybe Integer
-> ImplicitIdDef
ImplicitIdDef
        { iidFieldType :: EntityNameHS -> FieldType
iidFieldType = \EntityNameHS
_ ->
            (PersistField t, Typeable t) => FieldType
forall t. (PersistField t, Typeable t) => FieldType
fieldTypeFromTypeable @t
        , iidFieldSqlType :: SqlType
iidFieldSqlType =
            Proxy t -> SqlType
forall a. PersistFieldSql a => Proxy a -> SqlType
sqlType (Proxy t
forall k (t :: k). Proxy t
Proxy @t)
        , iidType :: Bool -> Type -> Type
iidType =
            \Bool
_ Type
_ -> Typeable t => Type
forall k (t :: k). Typeable t => Type
liftType @t
        , iidDefault :: Maybe Text
iidDefault =
            Text -> Maybe Text
forall a. a -> Maybe a
Just Text
def
        , iidMaxLen :: Maybe Integer
iidMaxLen =
            -- this follows a special casing behavior that @persistent@ has done
            -- for a while now. this keeps folks code from breaking and probably
            -- is mostly what people want.
            [Maybe Integer] -> Maybe Integer
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
                [ Integer
200 Integer -> Maybe (t :~: Text) -> Maybe Integer
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Typeable t, Typeable Text) => Maybe (t :~: Text)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @t @Text
                , Integer
200 Integer -> Maybe (t :~: String) -> Maybe Integer
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Typeable t, Typeable String) => Maybe (t :~: String)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @t @String
                ]
        }

-- | Set the maximum length of the implied ID column. This is required for
-- any type where the associated 'SqlType' is a @TEXT@ or @VARCHAR@ sort of
-- thing.
--
-- @since 2.13.0.0
setImplicitIdDefMaxLen
    :: Integer
    -> ImplicitIdDef
    -> ImplicitIdDef
setImplicitIdDefMaxLen :: Integer -> ImplicitIdDef -> ImplicitIdDef
setImplicitIdDefMaxLen Integer
i ImplicitIdDef
iid = ImplicitIdDef
iid { iidMaxLen :: Maybe Integer
iidMaxLen = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
i }

-- |  This function converts a 'Typeable' type into a @persistent@
-- representation of the type of a field - 'FieldTyp'.
--
-- @since 2.13.0.0
fieldTypeFromTypeable :: forall t. (PersistField t, Typeable t) => FieldType
fieldTypeFromTypeable :: FieldType
fieldTypeFromTypeable = TypeRep t -> FieldType
forall k (a :: k). TypeRep a -> FieldType
go (Typeable t => TypeRep t
forall k (a :: k). Typeable a => TypeRep a
typeRep @t)
  where
    go :: forall k (a :: k). TypeRep a -> FieldType
    go :: TypeRep a -> FieldType
go TypeRep a
tr =
        case TypeRep a
tr of
            Con TyCon
tyCon ->
                Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing (Text -> FieldType) -> Text -> FieldType
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TyCon -> String
tyConName TyCon
tyCon
            App TypeRep a
trA TypeRep b
trB ->
                FieldType -> FieldType -> FieldType
FTApp (TypeRep a -> FieldType
forall k (a :: k). TypeRep a -> FieldType
go TypeRep a
trA) (TypeRep b -> FieldType
forall k (a :: k). TypeRep a -> FieldType
go TypeRep b
trB)
            Fun TypeRep arg
_ TypeRep res
_ ->
                String -> FieldType
forall a. HasCallStack => String -> a
error String
"No functions in field defs."

-- | Remove the default attribute of the 'ImplicitIdDef' column. This will
-- require you to provide an ID for the model with every insert, using
-- 'insertKey' instead of 'insert', unless the type has some means of getting
-- around that in the migrations.
--
-- As an example, the Postgresql @SERIAL@ type expands to an autoincrementing
-- integer. Postgres will implicitly create the relevant series and set the
-- default to be @NEXTVAL('series_name')@. A default is therefore unnecessary to
-- use for this type.
--
-- However, for a @UUID@, postgres *does not* have an implicit default. You must
-- either specify a default UUID generation function, or insert them yourself
-- (again, using 'insertKey').
--
-- This function will be deprecated in the future when omiting the default
-- implicit ID column is more fully supported.
--
-- @since 2.13.0.0
unsafeClearDefaultImplicitId :: ImplicitIdDef -> ImplicitIdDef
unsafeClearDefaultImplicitId :: ImplicitIdDef -> ImplicitIdDef
unsafeClearDefaultImplicitId ImplicitIdDef
iid = ImplicitIdDef
iid { iidDefault :: Maybe Text
iidDefault = Maybe Text
forall a. Maybe a
Nothing }