{-# LANGUAGE CPP #-}

-- | Common 'DatabasePredicate's used for defining schemas
module Database.Beam.Migrate.Types.Predicates where

import Database.Beam
import Database.Beam.Backend.SQL.SQL92 (IsSql92TableNameSyntax(..))
import Database.Beam.Schema.Tables

import Control.DeepSeq

import Data.Aeson
import Data.Text (Text)
import Data.Hashable
import Data.Typeable

#if !MIN_VERSION_base(4, 11, 0)
import           Data.Semigroup
#endif

import Lens.Micro ((^.))

-- * Predicates

-- | A predicate is a type that describes some condition that the database
-- schema must meet. Beam represents database schemas as the set of all
-- predicates that apply to a database schema. The 'Hashable' and 'Eq' instances
-- allow us to build 'HashSet's of predicates to represent schemas in this way.
class (Typeable p, Hashable p, Eq p) => DatabasePredicate p where
  -- | An english language description of this predicate. For example, "There is
  -- a table named 'TableName'"
  englishDescription :: p -> String

  -- | Whether or not this predicate applies to all backends or only one
  -- backend. This is used when attempting to translate schemas between
  -- backends. If you are unsure, provide 'PredicateSpecificityOnlyBackend'
  -- along with an identifier unique to your backend.
  predicateSpecificity :: proxy p -> PredicateSpecificity

  -- | Serialize a predicate to a JSON 'Value'.
  serializePredicate :: p -> Value

  -- | Some predicates require other predicates to be true. For example, in
  -- order for a table to have a column, that table must exist. This function
  -- takes in the current predicate and another arbitrary database predicate. It
  -- should return 'True' if this predicate needs the other predicate to be true
  -- in order to exist.
  --
  -- By default, this simply returns 'False', which makes sense for many
  -- predicates.
  predicateCascadesDropOn :: DatabasePredicate p' => p -> p' -> Bool
  predicateCascadesDropOn p
_ p'
_ = Bool
False

-- | A Database predicate is a value of any type which satisfies
-- 'DatabasePredicate'. We often want to store these in lists and sets, so we
-- need a monomorphic container that can store these polymorphic values.
data SomeDatabasePredicate where
  SomeDatabasePredicate :: DatabasePredicate p
                        => p -> SomeDatabasePredicate

instance NFData SomeDatabasePredicate where
  rnf :: SomeDatabasePredicate -> ()
rnf SomeDatabasePredicate
p' = SomeDatabasePredicate
p' SomeDatabasePredicate -> () -> ()
`seq` ()

instance Show SomeDatabasePredicate where
  showsPrec :: Int -> SomeDatabasePredicate -> ShowS
showsPrec Int
_ (SomeDatabasePredicate p
p') =
    (Char
'('Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> ShowS
forall a. Show a => a -> ShowS
shows (p -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf p
p') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (p -> String
forall p. DatabasePredicate p => p -> String
englishDescription p
p' String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
')'Char -> ShowS
forall a. a -> [a] -> [a]
:)
instance Eq SomeDatabasePredicate where
  SomeDatabasePredicate p
a == :: SomeDatabasePredicate -> SomeDatabasePredicate -> Bool
== SomeDatabasePredicate p
b =
    case p -> Maybe p
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast p
a of
      Maybe p
Nothing -> Bool
False
      Just p
a' -> p
a' p -> p -> Bool
forall a. Eq a => a -> a -> Bool
== p
b
instance Hashable SomeDatabasePredicate where
  hashWithSalt :: Int -> SomeDatabasePredicate -> Int
hashWithSalt Int
salt (SomeDatabasePredicate p
p') = Int -> (TypeRep, p) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt (p -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf p
p', p
p')

-- | Some predicates make sense in any backend. Others only make sense in one.
-- This denotes the difference.
data PredicateSpecificity
  = PredicateSpecificityOnlyBackend String
  | PredicateSpecificityAllBackends
  deriving (Int -> PredicateSpecificity -> ShowS
[PredicateSpecificity] -> ShowS
PredicateSpecificity -> String
(Int -> PredicateSpecificity -> ShowS)
-> (PredicateSpecificity -> String)
-> ([PredicateSpecificity] -> ShowS)
-> Show PredicateSpecificity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PredicateSpecificity] -> ShowS
$cshowList :: [PredicateSpecificity] -> ShowS
show :: PredicateSpecificity -> String
$cshow :: PredicateSpecificity -> String
showsPrec :: Int -> PredicateSpecificity -> ShowS
$cshowsPrec :: Int -> PredicateSpecificity -> ShowS
Show, PredicateSpecificity -> PredicateSpecificity -> Bool
(PredicateSpecificity -> PredicateSpecificity -> Bool)
-> (PredicateSpecificity -> PredicateSpecificity -> Bool)
-> Eq PredicateSpecificity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PredicateSpecificity -> PredicateSpecificity -> Bool
$c/= :: PredicateSpecificity -> PredicateSpecificity -> Bool
== :: PredicateSpecificity -> PredicateSpecificity -> Bool
$c== :: PredicateSpecificity -> PredicateSpecificity -> Bool
Eq, (forall x. PredicateSpecificity -> Rep PredicateSpecificity x)
-> (forall x. Rep PredicateSpecificity x -> PredicateSpecificity)
-> Generic PredicateSpecificity
forall x. Rep PredicateSpecificity x -> PredicateSpecificity
forall x. PredicateSpecificity -> Rep PredicateSpecificity x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PredicateSpecificity x -> PredicateSpecificity
$cfrom :: forall x. PredicateSpecificity -> Rep PredicateSpecificity x
Generic)
instance Hashable PredicateSpecificity

instance ToJSON PredicateSpecificity where
  toJSON :: PredicateSpecificity -> Value
toJSON PredicateSpecificity
PredicateSpecificityAllBackends = Value
"all"
  toJSON (PredicateSpecificityOnlyBackend String
s)  = [Pair] -> Value
object [ Key
"backend" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String -> Value
forall a. ToJSON a => a -> Value
toJSON String
s ]
instance FromJSON PredicateSpecificity where
  parseJSON :: Value -> Parser PredicateSpecificity
parseJSON Value
"all" = PredicateSpecificity -> Parser PredicateSpecificity
forall (f :: * -> *) a. Applicative f => a -> f a
pure PredicateSpecificity
PredicateSpecificityAllBackends
  parseJSON (Object Object
o) = String -> PredicateSpecificity
PredicateSpecificityOnlyBackend (String -> PredicateSpecificity)
-> Parser String -> Parser PredicateSpecificity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"backend"
  parseJSON Value
_ = String -> Parser PredicateSpecificity
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"PredicateSource"

-- | Convenience synonym for 'SomeDatabasePredicate'
p :: DatabasePredicate p => p -> SomeDatabasePredicate
p :: forall p. DatabasePredicate p => p -> SomeDatabasePredicate
p = p -> SomeDatabasePredicate
forall p. DatabasePredicate p => p -> SomeDatabasePredicate
SomeDatabasePredicate

-- * Entity checks
--
--   When building checked database schemas, oftentimes the names of entities
--   may change. For example, a 'defaulMigratableDbSettings' object can have its
--   tables renamed. The checks need to update in order to reflect these name
--   changes. The following types represent predicates whose names have not yet
--   been determined.

-- | A name in a schema
data QualifiedName = QualifiedName (Maybe Text) Text
  deriving (Int -> QualifiedName -> ShowS
[QualifiedName] -> ShowS
QualifiedName -> String
(Int -> QualifiedName -> ShowS)
-> (QualifiedName -> String)
-> ([QualifiedName] -> ShowS)
-> Show QualifiedName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QualifiedName] -> ShowS
$cshowList :: [QualifiedName] -> ShowS
show :: QualifiedName -> String
$cshow :: QualifiedName -> String
showsPrec :: Int -> QualifiedName -> ShowS
$cshowsPrec :: Int -> QualifiedName -> ShowS
Show, QualifiedName -> QualifiedName -> Bool
(QualifiedName -> QualifiedName -> Bool)
-> (QualifiedName -> QualifiedName -> Bool) -> Eq QualifiedName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QualifiedName -> QualifiedName -> Bool
$c/= :: QualifiedName -> QualifiedName -> Bool
== :: QualifiedName -> QualifiedName -> Bool
$c== :: QualifiedName -> QualifiedName -> Bool
Eq, Eq QualifiedName
Eq QualifiedName
-> (QualifiedName -> QualifiedName -> Ordering)
-> (QualifiedName -> QualifiedName -> Bool)
-> (QualifiedName -> QualifiedName -> Bool)
-> (QualifiedName -> QualifiedName -> Bool)
-> (QualifiedName -> QualifiedName -> Bool)
-> (QualifiedName -> QualifiedName -> QualifiedName)
-> (QualifiedName -> QualifiedName -> QualifiedName)
-> Ord QualifiedName
QualifiedName -> QualifiedName -> Bool
QualifiedName -> QualifiedName -> Ordering
QualifiedName -> QualifiedName -> QualifiedName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: QualifiedName -> QualifiedName -> QualifiedName
$cmin :: QualifiedName -> QualifiedName -> QualifiedName
max :: QualifiedName -> QualifiedName -> QualifiedName
$cmax :: QualifiedName -> QualifiedName -> QualifiedName
>= :: QualifiedName -> QualifiedName -> Bool
$c>= :: QualifiedName -> QualifiedName -> Bool
> :: QualifiedName -> QualifiedName -> Bool
$c> :: QualifiedName -> QualifiedName -> Bool
<= :: QualifiedName -> QualifiedName -> Bool
$c<= :: QualifiedName -> QualifiedName -> Bool
< :: QualifiedName -> QualifiedName -> Bool
$c< :: QualifiedName -> QualifiedName -> Bool
compare :: QualifiedName -> QualifiedName -> Ordering
$ccompare :: QualifiedName -> QualifiedName -> Ordering
Ord)

instance ToJSON QualifiedName where
  toJSON :: QualifiedName -> Value
toJSON (QualifiedName Maybe Text
Nothing Text
t) = Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
t
  toJSON (QualifiedName (Just Text
s) Text
t) = [Pair] -> Value
object [ Key
"schema" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
s, Key
"name" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
t ]

instance FromJSON QualifiedName where
  parseJSON :: Value -> Parser QualifiedName
parseJSON s :: Value
s@(String {}) = Maybe Text -> Text -> QualifiedName
QualifiedName Maybe Text
forall a. Maybe a
Nothing (Text -> QualifiedName) -> Parser Text -> Parser QualifiedName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON Value
s
  parseJSON (Object Object
o) = Maybe Text -> Text -> QualifiedName
QualifiedName (Maybe Text -> Text -> QualifiedName)
-> Parser (Maybe Text) -> Parser (Text -> QualifiedName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"schema" Parser (Text -> QualifiedName)
-> Parser Text -> Parser QualifiedName
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
  parseJSON Value
_ = String -> Parser QualifiedName
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"QualifiedName: expects either string or {schema: ..., name: ...}"

instance Hashable QualifiedName where
  hashWithSalt :: Int -> QualifiedName -> Int
hashWithSalt Int
s (QualifiedName Maybe Text
sch Text
t) =
    Int -> (Maybe Text, Text) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Maybe Text
sch, Text
t)

qname :: IsDatabaseEntity be entity => DatabaseEntityDescriptor be entity -> QualifiedName
qname :: forall be entity.
IsDatabaseEntity be entity =>
DatabaseEntityDescriptor be entity -> QualifiedName
qname DatabaseEntityDescriptor be entity
e = Maybe Text -> Text -> QualifiedName
QualifiedName (DatabaseEntityDescriptor be entity
e DatabaseEntityDescriptor be entity
-> Getting
     (Maybe Text) (DatabaseEntityDescriptor be entity) (Maybe Text)
-> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe Text) (DatabaseEntityDescriptor be entity) (Maybe Text)
forall be entityType.
IsDatabaseEntity be entityType =>
Traversal' (DatabaseEntityDescriptor be entityType) (Maybe Text)
dbEntitySchema) (DatabaseEntityDescriptor be entity
e DatabaseEntityDescriptor be entity
-> Getting Text (DatabaseEntityDescriptor be entity) Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text (DatabaseEntityDescriptor be entity) Text
forall be entityType.
IsDatabaseEntity be entityType =>
Lens' (DatabaseEntityDescriptor be entityType) Text
dbEntityName)

qnameAsText :: QualifiedName -> Text
qnameAsText :: QualifiedName -> Text
qnameAsText (QualifiedName Maybe Text
Nothing Text
tbl) = Text
tbl
qnameAsText (QualifiedName (Just Text
sch) Text
tbl) = Text
sch Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tbl

qnameAsTableName :: IsSql92TableNameSyntax syntax => QualifiedName -> syntax
qnameAsTableName :: forall syntax.
IsSql92TableNameSyntax syntax =>
QualifiedName -> syntax
qnameAsTableName (QualifiedName Maybe Text
sch Text
t) = Maybe Text -> Text -> syntax
forall tblName.
IsSql92TableNameSyntax tblName =>
Maybe Text -> Text -> tblName
tableName Maybe Text
sch Text
t

-- | An optional predicate that depends on the name of a table as well as its fields
newtype TableCheck = TableCheck (forall tbl. Table tbl => QualifiedName -> tbl (TableField tbl) -> Maybe SomeDatabasePredicate)

-- | A predicate that depends on the name of a domain type
newtype DomainCheck = DomainCheck (QualifiedName -> SomeDatabasePredicate)

-- | A predicate that depends on the name of a table and one of its fields
newtype FieldCheck = FieldCheck (QualifiedName -> Text -> SomeDatabasePredicate)