{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Database.Beam.AutoMigrate.Schema.Gen
  ( genSchema,
    genSimilarSchemas,
    SimilarSchemas (..),
    shrinkSchema,
  )
where

import Control.Monad
import Control.Monad.State.Strict
import Data.Foldable (foldlM)
import Data.Functor ((<&>))
import Data.Functor.Identity
import Data.Int (Int16, Int32, Int64)
import qualified Data.Map.Strict as M
import Data.Proxy
import Data.Scientific (Scientific, scientific)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (Day, LocalTime, TimeOfDay)
import Data.Word
import Database.Beam.AutoMigrate (HasColumnType, defaultColumnType, sqlSingleQuoted)
import Database.Beam.AutoMigrate.Annotated (pgDefaultConstraint)
import Database.Beam.AutoMigrate.Types
import Database.Beam.Backend.SQL (HasSqlValueSyntax, timestampType)
import qualified Database.Beam.Backend.SQL.AST as AST
import Database.Beam.Backend.SQL.Types (SqlSerial (..))
import qualified Database.Beam.Postgres as Pg
import qualified Database.Beam.Postgres.Syntax as Pg
import Database.Beam.Query (currentTimestamp_, val_)
import GHC.Generics
import Test.QuickCheck
import Test.QuickCheck.Instances.Time ()
import Text.Printf (printf)

--
-- Arbitrary instances
--

instance Arbitrary Schema where
  arbitrary :: Gen Schema
arbitrary = Gen Schema
genSchema
  shrink :: Schema -> [Schema]
shrink = Schema -> [Schema]
shrinkSchema

newtype SimilarSchemas = SimilarSchemas {SimilarSchemas -> (Schema, Schema)
unSchemas :: (Schema, Schema)}
  deriving ((forall x. SimilarSchemas -> Rep SimilarSchemas x)
-> (forall x. Rep SimilarSchemas x -> SimilarSchemas)
-> Generic SimilarSchemas
forall x. Rep SimilarSchemas x -> SimilarSchemas
forall x. SimilarSchemas -> Rep SimilarSchemas x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SimilarSchemas x -> SimilarSchemas
$cfrom :: forall x. SimilarSchemas -> Rep SimilarSchemas x
Generic, Int -> SimilarSchemas -> ShowS
[SimilarSchemas] -> ShowS
SimilarSchemas -> String
(Int -> SimilarSchemas -> ShowS)
-> (SimilarSchemas -> String)
-> ([SimilarSchemas] -> ShowS)
-> Show SimilarSchemas
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SimilarSchemas] -> ShowS
$cshowList :: [SimilarSchemas] -> ShowS
show :: SimilarSchemas -> String
$cshow :: SimilarSchemas -> String
showsPrec :: Int -> SimilarSchemas -> ShowS
$cshowsPrec :: Int -> SimilarSchemas -> ShowS
Show)

instance Arbitrary SimilarSchemas where
  arbitrary :: Gen SimilarSchemas
arbitrary = (Schema, Schema) -> SimilarSchemas
SimilarSchemas ((Schema, Schema) -> SimilarSchemas)
-> Gen (Schema, Schema) -> Gen SimilarSchemas
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Schema, Schema)
genSimilarSchemas
  shrink :: SimilarSchemas -> [SimilarSchemas]
shrink = SimilarSchemas -> [SimilarSchemas]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink

--
-- Generators
--

genAlphaName :: Gen Text
genAlphaName :: Gen Text
genAlphaName = String -> Text
T.pack (String -> Text) -> Gen String -> Gen Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Char -> Gen String
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
10 (String -> Gen Char
forall a. [a] -> Gen a
elements (String -> Gen Char) -> String -> Gen Char
forall a b. (a -> b) -> a -> b
$ [Char
'a' .. Char
'z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'A' .. Char
'Z'])

genName :: (Text -> a) -> Gen a
genName :: (Text -> a) -> Gen a
genName Text -> a
f = Text -> a
f (Text -> a) -> Gen Text -> Gen a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text
genAlphaName

genTableName :: Gen TableName
genTableName :: Gen TableName
genTableName = (Text -> TableName) -> Gen TableName
forall a. (Text -> a) -> Gen a
genName Text -> TableName
TableName

genColumnName :: Gen ColumnName
genColumnName :: Gen ColumnName
genColumnName = (Text -> ColumnName) -> Gen ColumnName
forall a. (Text -> a) -> Gen a
genName Text -> ColumnName
ColumnName

-- | Generates a \"UNIQUE\" constraint. Restricts the eligible columns to only the ones which has
-- \"standard\" SQL types, to avoid the complication of dealing with indexes. For example trying to use
-- a JSON column would have Postgres fail with an error like:
-- \"[..]data type json has no default operator class for access method btree[..]\"
genUniqueConstraint :: Columns -> Gen (Set TableConstraint)
genUniqueConstraint :: Columns -> Gen (Set TableConstraint)
genUniqueConstraint Columns
allCols = do
  [ColumnName]
someCols <- ((ColumnName, Column) -> ColumnName)
-> [(ColumnName, Column)] -> [ColumnName]
forall a b. (a -> b) -> [a] -> [b]
map (ColumnName, Column) -> ColumnName
forall a b. (a, b) -> a
fst ([(ColumnName, Column)] -> [ColumnName])
-> ([(ColumnName, Column)] -> [(ColumnName, Column)])
-> [(ColumnName, Column)]
-> [ColumnName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ColumnName, Column) -> Bool)
-> [(ColumnName, Column)] -> [(ColumnName, Column)]
forall a. (a -> Bool) -> [a] -> [a]
filter (ColumnName, Column) -> Bool
isStdType ([(ColumnName, Column)] -> [(ColumnName, Column)])
-> ([(ColumnName, Column)] -> [(ColumnName, Column)])
-> [(ColumnName, Column)]
-> [(ColumnName, Column)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [(ColumnName, Column)] -> [(ColumnName, Column)]
forall a. Int -> [a] -> [a]
take Int
32 ([(ColumnName, Column)] -> [ColumnName])
-> Gen [(ColumnName, Column)] -> Gen [ColumnName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (ColumnName, Column) -> Gen [(ColumnName, Column)]
forall a. Gen a -> Gen [a]
listOf1 ([(ColumnName, Column)] -> Gen (ColumnName, Column)
forall a. [a] -> Gen a
elements ([(ColumnName, Column)] -> Gen (ColumnName, Column))
-> [(ColumnName, Column)] -> Gen (ColumnName, Column)
forall a b. (a -> b) -> a -> b
$ Columns -> [(ColumnName, Column)]
forall k a. Map k a -> [(k, a)]
M.toList Columns
allCols) -- indexes are capped to 32 colums.
  case [ColumnName]
someCols of
    [] -> Set TableConstraint -> Gen (Set TableConstraint)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set TableConstraint
forall a. Monoid a => a
mempty
    [ColumnName]
_ -> do
      Text
constraintName <- Identity Text -> Text
forall a. Identity a -> a
runIdentity (Identity Text -> Text) -> Gen (Identity Text) -> Gen Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Identity Text) -> Gen (Identity Text)
forall a. (Text -> a) -> Gen a
genName Text -> Identity Text
forall a. a -> Identity a
Identity
      Set TableConstraint -> Gen (Set TableConstraint)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set TableConstraint -> Gen (Set TableConstraint))
-> Set TableConstraint -> Gen (Set TableConstraint)
forall a b. (a -> b) -> a -> b
$ TableConstraint -> Set TableConstraint
forall a. a -> Set a
S.singleton (TableConstraint -> Set TableConstraint)
-> TableConstraint -> Set TableConstraint
forall a b. (a -> b) -> a -> b
$ Text -> Set ColumnName -> TableConstraint
Unique (Text
constraintName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_unique") ([ColumnName] -> Set ColumnName
forall a. Ord a => [a] -> Set a
S.fromList [ColumnName]
someCols)

isStdType :: (ColumnName, Column) -> Bool
isStdType :: (ColumnName, Column) -> Bool
isStdType (ColumnName
_, Column -> ColumnType
columnType -> SqlStdType DataType
_) = Bool
True
isStdType (ColumnName, Column)
_ = Bool
False

-- Generate a PK constraint.
-- /nota bene/: we have to require each and every column that compose this PK to be 'NotNull'. This is
-- important because otherwise Postgres will assume so even though we didn't generate this constraint in
-- the first place, and our roundtrip tests will fail.
-- Same consideration on the \"standard types\" applies as above (crf 'genUniqueConstraint').
genPkConstraint :: Columns -> Gen (Set TableConstraint)
genPkConstraint :: Columns -> Gen (Set TableConstraint)
genPkConstraint Columns
allCols = do
  [(ColumnName, Column)]
someCols <- Int -> [(ColumnName, Column)] -> [(ColumnName, Column)]
forall a. Int -> [a] -> [a]
take Int
32 ([(ColumnName, Column)] -> [(ColumnName, Column)])
-> ([(ColumnName, Column)] -> [(ColumnName, Column)])
-> [(ColumnName, Column)]
-> [(ColumnName, Column)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ColumnName, Column) -> Bool)
-> [(ColumnName, Column)] -> [(ColumnName, Column)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ColumnName, Column)
x -> (ColumnName, Column) -> Bool
isStdType (ColumnName, Column)
x Bool -> Bool -> Bool
&& (ColumnName, Column) -> Bool
notNull (ColumnName, Column)
x) ([(ColumnName, Column)] -> [(ColumnName, Column)])
-> Gen [(ColumnName, Column)] -> Gen [(ColumnName, Column)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (ColumnName, Column) -> Gen [(ColumnName, Column)]
forall a. Gen a -> Gen [a]
listOf1 ([(ColumnName, Column)] -> Gen (ColumnName, Column)
forall a. [a] -> Gen a
elements ([(ColumnName, Column)] -> Gen (ColumnName, Column))
-> [(ColumnName, Column)] -> Gen (ColumnName, Column)
forall a b. (a -> b) -> a -> b
$ Columns -> [(ColumnName, Column)]
forall k a. Map k a -> [(k, a)]
M.toList Columns
allCols) -- indexes are capped to 32 colums.
  case [(ColumnName, Column)]
someCols of
    [] -> Set TableConstraint -> Gen (Set TableConstraint)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set TableConstraint
forall a. Monoid a => a
mempty
    [(ColumnName, Column)]
_ -> do
      Text
constraintName <- Identity Text -> Text
forall a. Identity a -> a
runIdentity (Identity Text -> Text) -> Gen (Identity Text) -> Gen Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Identity Text) -> Gen (Identity Text)
forall a. (Text -> a) -> Gen a
genName Text -> Identity Text
forall a. a -> Identity a
Identity
      Set TableConstraint -> Gen (Set TableConstraint)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set TableConstraint -> Gen (Set TableConstraint))
-> Set TableConstraint -> Gen (Set TableConstraint)
forall a b. (a -> b) -> a -> b
$ TableConstraint -> Set TableConstraint
forall a. a -> Set a
S.singleton (TableConstraint -> Set TableConstraint)
-> TableConstraint -> Set TableConstraint
forall a b. (a -> b) -> a -> b
$ Text -> Set ColumnName -> TableConstraint
PrimaryKey (Text
constraintName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_pk") ([ColumnName] -> Set ColumnName
forall a. Ord a => [a] -> Set a
S.fromList ([ColumnName] -> Set ColumnName) -> [ColumnName] -> Set ColumnName
forall a b. (a -> b) -> a -> b
$ ((ColumnName, Column) -> ColumnName)
-> [(ColumnName, Column)] -> [ColumnName]
forall a b. (a -> b) -> [a] -> [b]
map (ColumnName, Column) -> ColumnName
forall a b. (a, b) -> a
fst [(ColumnName, Column)]
someCols)
  where
    notNull :: (ColumnName, Column) -> Bool
    notNull :: (ColumnName, Column) -> Bool
notNull (ColumnName
_, Column
col) = ColumnConstraint
NotNull ColumnConstraint -> Set ColumnConstraint -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Column -> Set ColumnConstraint
columnConstraints Column
col

genTableConstraints :: Tables -> Columns -> Gen (Set TableConstraint)
genTableConstraints :: Tables -> Columns -> Gen (Set TableConstraint)
genTableConstraints Tables
_allOtherTables Columns
ourColums =
  [(Int, Gen (Set TableConstraint))] -> Gen (Set TableConstraint)
forall a. [(Int, Gen a)] -> Gen a
frequency
    [ (Int
60, Set TableConstraint -> Gen (Set TableConstraint)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set TableConstraint
forall a. Monoid a => a
mempty),
      (Int
30, Columns -> Gen (Set TableConstraint)
genUniqueConstraint Columns
ourColums),
      (Int
30, Columns -> Gen (Set TableConstraint)
genPkConstraint Columns
ourColums),
      (Int
15, Set TableConstraint -> Set TableConstraint -> Set TableConstraint
forall a. Monoid a => a -> a -> a
mappend (Set TableConstraint -> Set TableConstraint -> Set TableConstraint)
-> Gen (Set TableConstraint)
-> Gen (Set TableConstraint -> Set TableConstraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Columns -> Gen (Set TableConstraint)
genPkConstraint Columns
ourColums Gen (Set TableConstraint -> Set TableConstraint)
-> Gen (Set TableConstraint) -> Gen (Set TableConstraint)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Columns -> Gen (Set TableConstraint)
genUniqueConstraint Columns
ourColums)
    ]

-- Generate a 'ColumnType' alongside a possible default value.
genColumnType :: Gen (ColumnType, ColumnConstraint)
genColumnType :: Gen (ColumnType, ColumnConstraint)
genColumnType =
  [Gen (ColumnType, ColumnConstraint)]
-> Gen (ColumnType, ColumnConstraint)
forall a. [Gen a] -> Gen a
oneof
    [ Gen (ColumnType, ColumnConstraint)
genSqlStdType,
      Gen (ColumnType, ColumnConstraint)
genPgSpecificType
      -- See below why this is commented out. , _genDbEnumeration
    ]

-- | Rather than trying to generate __all__ the possible values, we restrict ourselves to only the types
-- we can conjure via the 'defaultColumnType' combinator at 'Database.Beam.AutoMigrate.Compat', and we piggyback
-- on 'beam-core' machinery in order to generate the default values.
genSqlStdType :: Gen (ColumnType, ColumnConstraint)
genSqlStdType :: Gen (ColumnType, ColumnConstraint)
genSqlStdType =
  [Gen (ColumnType, ColumnConstraint)]
-> Gen (ColumnType, ColumnConstraint)
forall a. [Gen a] -> Gen a
oneof
    [ Gen Int32 -> Proxy Int32 -> Gen (ColumnType, ColumnConstraint)
forall a.
(HasColumnType a, HasSqlValueSyntax PgValueSyntax a) =>
Gen a -> Proxy a -> Gen (ColumnType, ColumnConstraint)
genType Gen Int32
forall a. Arbitrary a => Gen a
arbitrary (Proxy Int32
forall k (t :: k). Proxy t
Proxy @Int32),
      Gen Int16 -> Proxy Int16 -> Gen (ColumnType, ColumnConstraint)
forall a.
(HasColumnType a, HasSqlValueSyntax PgValueSyntax a) =>
Gen a -> Proxy a -> Gen (ColumnType, ColumnConstraint)
genType Gen Int16
forall a. Arbitrary a => Gen a
arbitrary (Proxy Int16
forall k (t :: k). Proxy t
Proxy @Int16),
      Gen Int64 -> Proxy Int64 -> Gen (ColumnType, ColumnConstraint)
forall a.
(HasColumnType a, HasSqlValueSyntax PgValueSyntax a) =>
Gen a -> Proxy a -> Gen (ColumnType, ColumnConstraint)
genType Gen Int64
forall a. Arbitrary a => Gen a
arbitrary (Proxy Int64
forall k (t :: k). Proxy t
Proxy @Int64),
      Gen Word16 -> Proxy Word16 -> Gen (ColumnType, ColumnConstraint)
forall a.
(HasColumnType a, HasSqlValueSyntax PgValueSyntax a) =>
Gen a -> Proxy a -> Gen (ColumnType, ColumnConstraint)
genType Gen Word16
forall a. Arbitrary a => Gen a
arbitrary (Proxy Word16
forall k (t :: k). Proxy t
Proxy @Word16),
      Gen Word32 -> Proxy Word32 -> Gen (ColumnType, ColumnConstraint)
forall a.
(HasColumnType a, HasSqlValueSyntax PgValueSyntax a) =>
Gen a -> Proxy a -> Gen (ColumnType, ColumnConstraint)
genType Gen Word32
forall a. Arbitrary a => Gen a
arbitrary (Proxy Word32
forall k (t :: k). Proxy t
Proxy @Word32),
      Gen Word64 -> Proxy Word64 -> Gen (ColumnType, ColumnConstraint)
forall a.
(HasColumnType a, HasSqlValueSyntax PgValueSyntax a) =>
Gen a -> Proxy a -> Gen (ColumnType, ColumnConstraint)
genType Gen Word64
forall a. Arbitrary a => Gen a
arbitrary (Proxy Word64
forall k (t :: k). Proxy t
Proxy @Word64),
      Gen Text -> Proxy Text -> Gen (ColumnType, ColumnConstraint)
forall a.
(HasColumnType a, HasSqlValueSyntax PgValueSyntax a) =>
Gen a -> Proxy a -> Gen (ColumnType, ColumnConstraint)
genType Gen Text
genAlphaName (Proxy Text
forall k (t :: k). Proxy t
Proxy @Text),
      Gen (ColumnType, ColumnConstraint)
genBitStringType,
      -- Unfortunately subject to rounding errors if a truly arbitrary type is used.
      -- For example '1.0' is rendered '1.0' by Beam but as '1' by Postgres.
      Gen Double -> Proxy Double -> Gen (ColumnType, ColumnConstraint)
forall a.
(HasColumnType a, HasSqlValueSyntax PgValueSyntax a) =>
Gen a -> Proxy a -> Gen (ColumnType, ColumnConstraint)
genType ([Double] -> Gen Double
forall a. [a] -> Gen a
elements [-Double
0.1, Double
3.5]) (Proxy Double
forall k (t :: k). Proxy t
Proxy @Double),
      -- Unfortunately subject to rounding errors if a truly arbitrary type is used.
      Gen Scientific
-> Proxy Scientific -> Gen (ColumnType, ColumnConstraint)
forall a.
(HasColumnType a, HasSqlValueSyntax PgValueSyntax a) =>
Gen a -> Proxy a -> Gen (ColumnType, ColumnConstraint)
genType (Scientific -> Gen Scientific
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Int -> Scientific
scientific (Integer
1 :: Integer) (Int
1 :: Int))) (Proxy Scientific
forall k (t :: k). Proxy t
Proxy @Scientific),
      Gen Day -> Proxy Day -> Gen (ColumnType, ColumnConstraint)
forall a.
(HasColumnType a, HasSqlValueSyntax PgValueSyntax a) =>
Gen a -> Proxy a -> Gen (ColumnType, ColumnConstraint)
genType Gen Day
forall a. Arbitrary a => Gen a
arbitrary (Proxy Day
forall k (t :: k). Proxy t
Proxy @Day),
      -- Unfortunately subject to rounding errors if a truly arbitrary type is used.
      Gen TimeOfDay
-> Proxy TimeOfDay -> Gen (ColumnType, ColumnConstraint)
forall a.
(HasColumnType a, HasSqlValueSyntax PgValueSyntax a) =>
Gen a -> Proxy a -> Gen (ColumnType, ColumnConstraint)
genType (TimeOfDay -> Gen TimeOfDay
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> TimeOfDay
forall a. Read a => String -> a
read String
"01:00:07.979173" :: TimeOfDay)) (Proxy TimeOfDay
forall k (t :: k). Proxy t
Proxy @TimeOfDay),
      Gen Bool -> Proxy Bool -> Gen (ColumnType, ColumnConstraint)
forall a.
(HasColumnType a, HasSqlValueSyntax PgValueSyntax a) =>
Gen a -> Proxy a -> Gen (ColumnType, ColumnConstraint)
genType Gen Bool
forall a. Arbitrary a => Gen a
arbitrary (Proxy Bool
forall k (t :: k). Proxy t
Proxy @Bool),
      -- Unfortunately subject to rounding errors if a truly arbitrary type is used.
      Gen LocalTime
-> Proxy LocalTime -> Gen (ColumnType, ColumnConstraint)
forall a.
(HasColumnType a, HasSqlValueSyntax PgValueSyntax a) =>
Gen a -> Proxy a -> Gen (ColumnType, ColumnConstraint)
genType (LocalTime -> Gen LocalTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> LocalTime
forall a. Read a => String -> a
read String
"1864-05-10 13:50:45.919197" :: LocalTime)) (Proxy LocalTime
forall k (t :: k). Proxy t
Proxy @LocalTime),
      -- Explicitly test for the 'CURRENT_TIMESTAMP' case.
      (ColumnType, ColumnConstraint)
-> Gen (ColumnType, ColumnConstraint)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DataType -> ColumnType
SqlStdType (DataType -> ColumnType) -> DataType -> ColumnType
forall a b. (a -> b) -> a -> b
$ Maybe Word -> Bool -> DataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Bool -> dataType
timestampType Maybe Word
forall a. Maybe a
Nothing Bool
False, (forall ctx s. QGenExpr ctx Postgres s LocalTime)
-> ColumnConstraint
forall ty.
(HasColumnType ty, HasSqlValueSyntax PgValueSyntax ty) =>
(forall ctx s. QGenExpr ctx Postgres s ty) -> ColumnConstraint
pgDefaultConstraint @LocalTime forall ctx s. QGenExpr ctx Postgres s LocalTime
forall be ctxt s. BeamSqlBackend be => QGenExpr ctxt be s LocalTime
currentTimestamp_),
      Gen (SqlSerial Int64)
-> Proxy (SqlSerial Int64) -> Gen (ColumnType, ColumnConstraint)
forall a.
(HasColumnType a, HasSqlValueSyntax PgValueSyntax a) =>
Gen a -> Proxy a -> Gen (ColumnType, ColumnConstraint)
genType ((Int64 -> SqlSerial Int64) -> Gen Int64 -> Gen (SqlSerial Int64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int64 -> SqlSerial Int64
forall a. a -> SqlSerial a
SqlSerial Gen Int64
forall a. Arbitrary a => Gen a
arbitrary) (Proxy (SqlSerial Int64)
forall k (t :: k). Proxy t
Proxy @(SqlSerial Int64))
    ]

genType ::
  forall a.
  ( HasColumnType a,
    HasSqlValueSyntax Pg.PgValueSyntax a
  ) =>
  Gen a ->
  Proxy a ->
  Gen (ColumnType, ColumnConstraint)
genType :: Gen a -> Proxy a -> Gen (ColumnType, ColumnConstraint)
genType Gen a
gen Proxy a
Proxy =
  (,) (ColumnType -> ColumnConstraint -> (ColumnType, ColumnConstraint))
-> Gen ColumnType
-> Gen (ColumnConstraint -> (ColumnType, ColumnConstraint))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ColumnType -> Gen ColumnType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Proxy a -> ColumnType
forall ty. HasColumnType ty => Proxy ty -> ColumnType
defaultColumnType (Proxy a
forall k (t :: k). Proxy t
Proxy @a))
    Gen (ColumnConstraint -> (ColumnType, ColumnConstraint))
-> Gen ColumnConstraint -> Gen (ColumnType, ColumnConstraint)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Gen a
gen Gen a -> (a -> ColumnConstraint) -> Gen ColumnConstraint
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\(a
x :: a) -> (forall ctx s. QGenExpr ctx Postgres s a) -> ColumnConstraint
forall ty.
(HasColumnType ty, HasSqlValueSyntax PgValueSyntax ty) =>
(forall ctx s. QGenExpr ctx Postgres s ty) -> ColumnConstraint
pgDefaultConstraint ((forall ctx s. QGenExpr ctx Postgres s a) -> ColumnConstraint)
-> (forall ctx s. QGenExpr ctx Postgres s a) -> ColumnConstraint
forall a b. (a -> b) -> a -> b
$ HaskellLiteralForQExpr (QGenExpr ctx Postgres s a)
-> QGenExpr ctx Postgres s a
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ a
HaskellLiteralForQExpr (QGenExpr ctx Postgres s a)
x))

-- | From postgres' documentation:
-- \"Bit strings are strings of 1's and 0's. They can be used to store or visualize bit masks. There are
-- two SQL bit types: bit(n) and bit varying(n), where n is a positive integer.
-- bit type data must match the length n exactly; it is an error to attempt to store shorter or longer bit
-- strings. bit varying data is of variable length up to the maximum length n; longer strings will be rejected.
-- Writing bit without a length is equivalent to bit(1), while bit varying without a length specification
-- means unlimited length.\"
-- /NOTE(and)/: This was not generated using the 'defaultsTo_' combinator, because it's unclear how
-- \"Beam\" allows the construction and handling of a 'SqlBitString', considering that it's treated
-- internally as an integer.
genBitStringType :: Gen (ColumnType, ColumnConstraint)
genBitStringType :: Gen (ColumnType, ColumnConstraint)
genBitStringType = do
  Bool
varying <- Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
  Word
charPrec <- [Word] -> Gen Word
forall a. [a] -> Gen a
elements [Word
1 :: Word, Word
2, Word
4, Word
6, Word
8, Word
16, Word
32, Word
64]
  String
string <- Int -> Gen Char -> Gen String
forall a. Int -> Gen a -> Gen [a]
vectorOf (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
charPrec) (String -> Gen Char
forall a. [a] -> Gen a
elements [Char
'0', Char
'1'])
  let txt :: Text
txt = Text -> Text
sqlSingleQuoted (String -> Text
T.pack String
string) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"::bit(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> (Word -> String) -> Word -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> String
forall a. Show a => a -> String
show (Word -> Text) -> Word -> Text
forall a b. (a -> b) -> a -> b
$ Word
charPrec) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  case Bool
varying of
    Bool
False ->
      (ColumnType, ColumnConstraint)
-> Gen (ColumnType, ColumnConstraint)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( DataType -> ColumnType
SqlStdType (DataType -> ColumnType) -> DataType -> ColumnType
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Word -> DataType
AST.DataTypeBit Bool
False (Word -> Maybe Word
forall a. a -> Maybe a
Just Word
charPrec),
          Text -> ColumnConstraint
Default Text
txt
        )
    Bool
True ->
      (ColumnType, ColumnConstraint)
-> Gen (ColumnType, ColumnConstraint)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( DataType -> ColumnType
SqlStdType (DataType -> ColumnType) -> DataType -> ColumnType
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Word -> DataType
AST.DataTypeBit Bool
True (Word -> Maybe Word
forall a. a -> Maybe a
Just Word
1),
          Text -> ColumnConstraint
Default Text
txt
        )

genPgSpecificType :: Gen (ColumnType, ColumnConstraint)
genPgSpecificType :: Gen (ColumnType, ColumnConstraint)
genPgSpecificType =
  [Gen (ColumnType, ColumnConstraint)]
-> Gen (ColumnType, ColumnConstraint)
forall a. [Gen a] -> Gen a
oneof
    [ Gen (PgJSON Int)
-> Proxy (PgJSON Int) -> Gen (ColumnType, ColumnConstraint)
forall a.
(HasColumnType a, HasSqlValueSyntax PgValueSyntax a) =>
Gen a -> Proxy a -> Gen (ColumnType, ColumnConstraint)
genType ((Int -> PgJSON Int) -> Gen Int -> Gen (PgJSON Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> PgJSON Int
forall a. a -> PgJSON a
Pg.PgJSON (Arbitrary Int => Gen Int
forall a. Arbitrary a => Gen a
arbitrary @Int)) (Proxy (PgJSON Int)
forall k (t :: k). Proxy t
Proxy @(Pg.PgJSON Int)),
      Gen (PgJSONB Int)
-> Proxy (PgJSONB Int) -> Gen (ColumnType, ColumnConstraint)
forall a.
(HasColumnType a, HasSqlValueSyntax PgValueSyntax a) =>
Gen a -> Proxy a -> Gen (ColumnType, ColumnConstraint)
genType ((Int -> PgJSONB Int) -> Gen Int -> Gen (PgJSONB Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> PgJSONB Int
forall a. a -> PgJSONB a
Pg.PgJSONB (Arbitrary Int => Gen Int
forall a. Arbitrary a => Gen a
arbitrary @Int)) (Proxy (PgJSONB Int)
forall k (t :: k). Proxy t
Proxy @(Pg.PgJSONB Int))
      -- , genRangeType (Proxy @Pg.PgInt4Range)            (Proxy @Int32)
      -- , genRangeType (Proxy @Pg.PgInt8Range)            (Proxy @Int)
      -- , genRangeType (Proxy @Pg.PgInt8Range)            (Proxy @Int64)
      -- , genRangeType (Proxy @Pg.PgNumRange)             (Proxy @Int)
      -- , genRangeType (Proxy @Pg.PgNumRange)             (Proxy @Word64)
      -- , genRangeType (Proxy @Pg.PgRangeTs)   (Proxy @LocalTime)
      -- , genRangeType (Proxy @Pg.RangeDate)   (Proxy @Day)
      -- , PgEnumeration EnumerationName
    ]

_genRangeType ::
  forall a n.
  ( Ord a,
    Num a,
    Arbitrary a,
    Pg.PgIsRange n,
    HasColumnType (Pg.PgRange n a),
    HasSqlValueSyntax Pg.PgValueSyntax a
  ) =>
  Proxy n ->
  Proxy a ->
  Gen (ColumnType, ColumnConstraint)
_genRangeType :: Proxy n -> Proxy a -> Gen (ColumnType, ColumnConstraint)
_genRangeType Proxy n
Proxy Proxy a
Proxy = do
  let colType :: ColumnType
colType = Proxy (PgRange n a) -> ColumnType
forall ty. HasColumnType ty => Proxy ty -> ColumnType
defaultColumnType (Proxy (PgRange n a)
forall k (t :: k). Proxy t
Proxy @(Pg.PgRange n a))
  PgBoundType
lowerBoundRange <- [PgBoundType] -> Gen PgBoundType
forall a. [a] -> Gen a
elements [PgBoundType
Pg.Inclusive, PgBoundType
Pg.Exclusive]
  PgBoundType
upperBoundRange <- [PgBoundType] -> Gen PgBoundType
forall a. [a] -> Gen a
elements [PgBoundType
Pg.Inclusive, PgBoundType
Pg.Exclusive]
  Maybe a
mbLower <- Arbitrary (Maybe a) => Gen (Maybe a)
forall a. Arbitrary a => Gen a
arbitrary @(Maybe a)
  Maybe (Positive a)
mbUpper <-
    Arbitrary (Maybe (Positive a)) => Gen (Maybe (Positive a))
forall a. Arbitrary a => Gen a
arbitrary @(Maybe (Positive a)) Gen (Maybe (Positive a))
-> (Maybe (Positive a) -> Maybe (Positive a))
-> Gen (Maybe (Positive a))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Maybe (Positive a)
u -> case (Positive a -> a -> (Positive a, a))
-> Maybe (Positive a) -> Maybe a -> Maybe (Positive a, a)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) Maybe (Positive a)
u Maybe a
mbLower of
      Maybe (Positive a, a)
Nothing -> Maybe (Positive a)
u
      Just (Positive a
ub, a
lb) -> Positive a -> Maybe (Positive a)
forall a. a -> Maybe a
Just (Positive a -> Maybe (Positive a))
-> Positive a -> Maybe (Positive a)
forall a b. (a -> b) -> a -> b
$ a -> Positive a
forall a. a -> Positive a
Positive (a -> Positive a) -> a -> Positive a
forall a b. (a -> b) -> a -> b
$ (Positive a -> a
forall a. Positive a -> a
getPositive Positive a
ub) a -> a -> a
forall a. Num a => a -> a -> a
+ a
lb a -> a -> a
forall a. Num a => a -> a -> a
+ a
1
  let dVal :: ColumnConstraint
dVal =
        (forall ctx s. QGenExpr ctx Postgres s (PgRange n a))
-> ColumnConstraint
forall ty.
(HasColumnType ty, HasSqlValueSyntax PgValueSyntax ty) =>
(forall ctx s. QGenExpr ctx Postgres s ty) -> ColumnConstraint
pgDefaultConstraint ((forall ctx s. QGenExpr ctx Postgres s (PgRange n a))
 -> ColumnConstraint)
-> (forall ctx s. QGenExpr ctx Postgres s (PgRange n a))
-> ColumnConstraint
forall a b. (a -> b) -> a -> b
$
          PgBoundType
-> PgBoundType
-> QGenExpr ctx Postgres s (Maybe a)
-> QGenExpr ctx Postgres s (Maybe a)
-> QGenExpr ctx Postgres s (PgRange n a)
forall n a context s.
PgIsRange n =>
PgBoundType
-> PgBoundType
-> QGenExpr context Postgres s (Maybe a)
-> QGenExpr context Postgres s (Maybe a)
-> QGenExpr context Postgres s (PgRange n a)
Pg.range_ @n @a PgBoundType
lowerBoundRange PgBoundType
upperBoundRange (HaskellLiteralForQExpr (QGenExpr ctx Postgres s (Maybe a))
-> QGenExpr ctx Postgres s (Maybe a)
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ Maybe a
HaskellLiteralForQExpr (QGenExpr ctx Postgres s (Maybe a))
mbLower) (HaskellLiteralForQExpr (QGenExpr ctx Postgres s (Maybe a))
-> QGenExpr ctx Postgres s (Maybe a)
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ ((Positive a -> a) -> Maybe (Positive a) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Positive a -> a
forall a. Positive a -> a
getPositive Maybe (Positive a)
mbUpper))
  (ColumnType, ColumnConstraint)
-> Gen (ColumnType, ColumnConstraint)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ColumnType, ColumnConstraint)
 -> Gen (ColumnType, ColumnConstraint))
-> (ColumnType, ColumnConstraint)
-> Gen (ColumnType, ColumnConstraint)
forall a b. (a -> b) -> a -> b
$ (ColumnType
colType, ColumnConstraint
dVal)

--
--
-- UNUSED GENERATORS
--
-- These are generators I (adn) wrote in order to hit all the possible 'AST.DataType', but ultimately we
-- are bound to only the types the user can generate via 'defaultsTo_', so we are currently not using these
-- one. If in the future new instances for 'HasColumnType' gets added, these might be handy again.
--

-- NOTE(adn) We currently cannot use this generator because we have no information on the DB side to
-- reconstruct the fact this was an enumeration, so any roundtrip property involving a 'DBEnumeration' will
-- fail.
_genDbEnumeration :: Gen (ColumnType, Text)
_genDbEnumeration :: Gen (ColumnType, Text)
_genDbEnumeration = do
  [Text]
vals <- (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
sqlSingleQuoted ([Text] -> [Text]) -> Gen [Text] -> Gen [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text -> Gen [Text]
forall a. Gen a -> Gen [a]
listOf1 Gen Text
genAlphaName
  Text
dVal <- [Text] -> Gen Text
forall a. [a] -> Gen a
elements [Text]
vals
  EnumerationName
name <- (Text -> EnumerationName) -> Gen EnumerationName
forall a. (Text -> a) -> Gen a
genName Text -> EnumerationName
EnumerationName
  (ColumnType, Text) -> Gen (ColumnType, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EnumerationName -> Enumeration -> ColumnType
DbEnumeration EnumerationName
name ([Text] -> Enumeration
Enumeration [Text]
vals), Text
dVal)

_defVal :: forall a. (Arbitrary a, Show a) => Proxy a -> Gen Text
_defVal :: Proxy a -> Gen Text
_defVal Proxy a
Proxy = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show (a -> Text) -> Gen a -> Gen Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Gen a
forall a. Arbitrary a => Gen a
arbitrary :: Gen a)

-- Postgres has \"float(8)\" which is an alias for \"double precision\", and \"float(4)\" which is
-- an alias for \"real\".
_genFloatType :: Gen (AST.DataType, Text)
_genFloatType :: Gen (DataType, Text)
_genFloatType = do
  Maybe Word
floatPrec <- [Maybe Word] -> Gen (Maybe Word)
forall a. [a] -> Gen a
elements [Maybe Word
forall a. Maybe a
Nothing, Word -> Maybe Word
forall a. a -> Maybe a
Just Word
4, Word -> Maybe Word
forall a. a -> Maybe a
Just Word
8]
  Text
def <- Proxy Float -> Gen Text
forall a. (Arbitrary a, Show a) => Proxy a -> Gen Text
_defVal @Float Proxy Float
forall k (t :: k). Proxy t
Proxy
  (DataType, Text) -> Gen (DataType, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Word -> DataType
AST.DataTypeFloat Maybe Word
floatPrec, Text
def)

-- real == float(8), i.e. 4 bytes.
_genRealType :: Gen (AST.DataType, Text)
_genRealType :: Gen (DataType, Text)
_genRealType = do
  Text
v <- String -> Text
T.pack (String -> Text) -> (Float -> String) -> Float -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Float -> String
forall r. PrintfType r => String -> r
printf String
"%.1f" (Float -> Text) -> Gen Float -> Gen Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Arbitrary Float => Gen Float
forall a. Arbitrary a => Gen a
arbitrary @Float
  (DataType, Text) -> Gen (DataType, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DataType
AST.DataTypeReal, Text -> Text
sqlSingleQuoted Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"::real")

_genIntType :: Gen (AST.DataType, Text)
_genIntType :: Gen (DataType, Text)
_genIntType = do
  Int32
v <- Arbitrary Int32 => Gen Int32
forall a. Arbitrary a => Gen a
arbitrary @Int32
  (DataType, Text) -> Gen (DataType, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((DataType, Text) -> Gen (DataType, Text))
-> (DataType, Text) -> Gen (DataType, Text)
forall a b. (a -> b) -> a -> b
$
    if Int32
v Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
< Int32
0
      then (DataType
AST.DataTypeBigInt, Text -> Text
sqlSingleQuoted (String -> Text
T.pack (String -> Text) -> (Int32 -> String) -> Int32 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> String
forall a. Show a => a -> String
show (Int32 -> Text) -> Int32 -> Text
forall a b. (a -> b) -> a -> b
$ Int32
v) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"::integer")
      else (DataType
AST.DataTypeBigInt, String -> Text
T.pack (String -> Text) -> (Int32 -> String) -> Int32 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> String
forall a. Show a => a -> String
show (Int32 -> Text) -> Int32 -> Text
forall a b. (a -> b) -> a -> b
$ Int32
v)

_genBigIntType :: Gen (AST.DataType, Text)
_genBigIntType :: Gen (DataType, Text)
_genBigIntType = do
  Integer
v <- Arbitrary Integer => Gen Integer
forall a. Arbitrary a => Gen a
arbitrary @Integer
  (DataType, Text) -> Gen (DataType, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((DataType, Text) -> Gen (DataType, Text))
-> (DataType, Text) -> Gen (DataType, Text)
forall a b. (a -> b) -> a -> b
$
    if Integer
v Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
      then (DataType
AST.DataTypeBigInt, Text -> Text
sqlSingleQuoted (String -> Text
T.pack (String -> Text) -> (Integer -> String) -> Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show (Integer -> Text) -> Integer -> Text
forall a b. (a -> b) -> a -> b
$ Integer
v) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"::integer")
      else (DataType
AST.DataTypeBigInt, String -> Text
T.pack (String -> Text) -> (Integer -> String) -> Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show (Integer -> Text) -> Integer -> Text
forall a b. (a -> b) -> a -> b
$ Integer
v)

-- | We do not render all the decimal digits to not incur in any rounding error when converting back from
-- Postgres.
_genDoublePrecisionType :: Gen (AST.DataType, Text)
_genDoublePrecisionType :: Gen (DataType, Text)
_genDoublePrecisionType = do
  Text
v <- String -> Text
T.pack (String -> Text) -> (Double -> String) -> Double -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.1f" (Double -> Text) -> Gen Double -> Gen Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Arbitrary Double => Gen Double
forall a. Arbitrary a => Gen a
arbitrary @Double
  (DataType, Text) -> Gen (DataType, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DataType
AST.DataTypeDoublePrecision, Text -> Text
sqlSingleQuoted Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"::double precision")

_genNumericType :: (Maybe (Word, Maybe Word) -> AST.DataType) -> Text -> Gen (AST.DataType, Text)
_genNumericType :: (Maybe (Word, Maybe Word) -> DataType)
-> Text -> Gen (DataType, Text)
_genNumericType Maybe (Word, Maybe Word) -> DataType
f Text
_cast = do
  Word
numPrec <- (Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
1 :: Word, Word
15)
  Word
numScale <- (Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
1 :: Word, Word
numPrec)
  Maybe (Word, Maybe Word)
p <- [Maybe (Word, Maybe Word)] -> Gen (Maybe (Word, Maybe Word))
forall a. [a] -> Gen a
elements [Maybe (Word, Maybe Word)
forall a. Maybe a
Nothing, (Word, Maybe Word) -> Maybe (Word, Maybe Word)
forall a. a -> Maybe a
Just (Word
numPrec, Maybe Word
forall a. Maybe a
Nothing), (Word, Maybe Word) -> Maybe (Word, Maybe Word)
forall a. a -> Maybe a
Just (Word
numPrec, Word -> Maybe Word
forall a. a -> Maybe a
Just Word
numScale)]
  let renderNum :: (a, a) -> Text
renderNum (a
a, a
b) = (String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show (a -> Text) -> a -> Text
forall a b. (a -> b) -> a -> b
$ a
a) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show (a -> Text) -> a -> Text
forall a b. (a -> b) -> a -> b
$ a
b)
  Text
defaultValue <- case Maybe (Word, Maybe Word)
p of
    Maybe (Word, Maybe Word)
Nothing ->
      [Gen Text] -> Gen Text
forall a. [Gen a] -> Gen a
oneof
        [ Proxy Int32 -> Gen Text
forall a. (Arbitrary a, Show a) => Proxy a -> Gen Text
_defVal @Int32 Proxy Int32
forall k (t :: k). Proxy t
Proxy,
          ((Word, Word) -> Text) -> Gen (Word, Word) -> Gen Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word, Word) -> Text
forall a a. (Show a, Show a) => (a, a) -> Text
renderNum ((,) (Word -> Word -> (Word, Word))
-> Gen Word -> Gen (Word -> (Word, Word))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
0 :: Word, Word
131072) Gen (Word -> (Word, Word)) -> Gen Word -> Gen (Word, Word)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
0 :: Word, Word
16383))
        ]
    Just (Word
_, Maybe Word
Nothing) ->
      [Gen Text] -> Gen Text
forall a. [Gen a] -> Gen a
oneof
        [ Proxy Int32 -> Gen Text
forall a. (Arbitrary a, Show a) => Proxy a -> Gen Text
_defVal @Int32 Proxy Int32
forall k (t :: k). Proxy t
Proxy,
          ((Word, Word) -> Text) -> Gen (Word, Word) -> Gen Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            (Word, Word) -> Text
forall a a. (Show a, Show a) => (a, a) -> Text
renderNum
            ( (,) (Word -> Word -> (Word, Word))
-> Gen Word -> Gen (Word -> (Word, Word))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
0 :: Word, Word
131072)) -- `suchThat` (\x -> length (show x) <= fromIntegral numPrec))
                Gen (Word -> (Word, Word)) -> Gen Word -> Gen (Word, Word)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
0 :: Word, Word
16383)
            )
        ]
    Just (Word
_, Just Word
_) ->
      [Gen Text] -> Gen Text
forall a. [Gen a] -> Gen a
oneof
        [ Proxy Int32 -> Gen Text
forall a. (Arbitrary a, Show a) => Proxy a -> Gen Text
_defVal @Int32 Proxy Int32
forall k (t :: k). Proxy t
Proxy,
          ((Word, Word) -> Text) -> Gen (Word, Word) -> Gen Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            (Word, Word) -> Text
forall a a. (Show a, Show a) => (a, a) -> Text
renderNum
            ( (,) (Word -> Word -> (Word, Word))
-> Gen Word -> Gen (Word -> (Word, Word))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
0 :: Word, Word
131072) -- `suchThat` (\x -> length (show x) <= fromIntegral numPrec)
                Gen (Word -> (Word, Word)) -> Gen Word -> Gen (Word, Word)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
0 :: Word, Word
16383) -- `suchThat` (\x -> length (show x) <= fromIntegral numScale)
            )
        ]
  (DataType, Text) -> Gen (DataType, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Word, Maybe Word) -> DataType
f Maybe (Word, Maybe Word)
p, Text
defaultValue)

-- Adjust the generator to the pg-specific caveats and quirks.
_pgSimplify :: (AST.DataType, Text) -> (AST.DataType, Text)
_pgSimplify :: (DataType, Text) -> (DataType, Text)
_pgSimplify = \case
  -- From the Postgres' documentation:
  -- \"character without length specifier is equivalent to character(1).\"
  (AST.DataTypeChar Bool
varying Maybe Word
Nothing Maybe Text
c, Text
def) -> (Bool -> Maybe Word -> Maybe Text -> DataType
AST.DataTypeChar Bool
varying (Word -> Maybe Word
forall a. a -> Maybe a
Just Word
1) Maybe Text
c, Text
def)
  -- Postgres doesn't distinguish between \"national character varying\" and \"character varying\".
  -- See <here https://stackoverflow.com/questions/57649798/postgresql-support-for-national-character-data-types>.
  (AST.DataTypeNationalChar Bool
varying Maybe Word
Nothing, Text
def) -> (Bool -> Maybe Word -> Maybe Text -> DataType
AST.DataTypeChar Bool
varying (Word -> Maybe Word
forall a. a -> Maybe a
Just Word
1) Maybe Text
forall a. Maybe a
Nothing, Text
def)
  (AST.DataTypeNationalChar Bool
varying Maybe Word
precision, Text
def) -> (Bool -> Maybe Word -> Maybe Text -> DataType
AST.DataTypeChar Bool
varying Maybe Word
precision Maybe Text
forall a. Maybe a
Nothing, Text
def)
  -- In Postgres decimal and numeric are isomorphic.
  (AST.DataTypeDecimal Maybe (Word, Maybe Word)
v, Text
def) -> (Maybe (Word, Maybe Word) -> DataType
AST.DataTypeNumeric Maybe (Word, Maybe Word)
v, Text
def)
  (AST.DataTypeFloat (Just Word
4), Text
def) -> (DataType
AST.DataTypeReal, Text
def)
  (AST.DataTypeFloat (Just Word
8), Text
def) -> (DataType
AST.DataTypeDoublePrecision, Text
def)
  (DataType, Text)
x -> (DataType, Text)
x

-- From the Postgres' documentation:
-- \"character without length specifier is equivalent to character(1).\"
_genCharType :: (Bool -> Maybe Word -> AST.DataType) -> Gen (AST.DataType, Text)
_genCharType :: (Bool -> Maybe Word -> DataType) -> Gen (DataType, Text)
_genCharType Bool -> Maybe Word -> DataType
f = do
  Bool
varying <- Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
  Text
text <- Gen Text
genAlphaName
  Word
charPrec <- (Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
1, Word
2048) -- 2048 is arbitrary (no pun intended) here.
  case Bool
varying of
    Bool
False -> (DataType, Text) -> Gen (DataType, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Maybe Word -> DataType
f Bool
False (Word -> Maybe Word
forall a. a -> Maybe a
Just Word
charPrec), Text -> Text
sqlSingleQuoted (Int -> Text -> Text
T.take (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
charPrec) Text
text) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"::bpchar")
    Bool
True -> (DataType, Text) -> Gen (DataType, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Maybe Word -> DataType
f Bool
True (Word -> Maybe Word
forall a. a -> Maybe a
Just Word
1), Text -> Text
sqlSingleQuoted Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"::character varying")

genColumn :: Columns -> Gen Column
genColumn :: Columns -> Gen Column
genColumn Columns
_allColums = do
  Int
constNum <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
2)
  (ColumnType
cType, ColumnConstraint
dVal) <- Gen (ColumnType, ColumnConstraint)
genColumnType
  [ColumnConstraint]
constrs <- Int -> Gen ColumnConstraint -> Gen [ColumnConstraint]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
constNum ([ColumnConstraint] -> Gen ColumnConstraint
forall a. [a] -> Gen a
elements [ColumnConstraint
NotNull, ColumnConstraint
dVal])
  Column -> Gen Column
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Column -> Gen Column) -> Column -> Gen Column
forall a b. (a -> b) -> a -> b
$ ColumnType -> Set ColumnConstraint -> Column
Column ColumnType
cType ([ColumnConstraint] -> Set ColumnConstraint
forall a. Ord a => [a] -> Set a
S.fromList [ColumnConstraint]
constrs)

genColumns :: Gen Columns
genColumns :: Gen Columns
genColumns = do
  Int
colNum <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
50)
  [ColumnName]
columnNames <- Int -> Gen ColumnName -> Gen [ColumnName]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
colNum Gen ColumnName
genColumnName
  (Columns -> ColumnName -> Gen Columns)
-> Columns -> [ColumnName] -> Gen Columns
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (\Columns
acc ColumnName
cName -> (Column -> Columns -> Columns) -> Columns -> Column -> Columns
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ColumnName -> Column -> Columns -> Columns
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ColumnName
cName) Columns
acc (Column -> Columns) -> Gen Column -> Gen Columns
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Columns -> Gen Column
genColumn Columns
acc) Columns
forall a. Monoid a => a
mempty [ColumnName]
columnNames

-- | Generate a new 'Table' using the already existing tables to populate the constraints.
genTable :: Tables -> Gen Table
genTable :: Tables -> Gen Table
genTable Tables
currentTables = do
  Columns
cols <- Gen Columns
genColumns
  Set TableConstraint -> Columns -> Table
Table (Set TableConstraint -> Columns -> Table)
-> Gen (Set TableConstraint) -> Gen (Columns -> Table)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tables -> Columns -> Gen (Set TableConstraint)
genTableConstraints Tables
currentTables Columns
cols Gen (Columns -> Table) -> Gen Columns -> Gen Table
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Columns -> Gen Columns
forall (f :: * -> *) a. Applicative f => a -> f a
pure Columns
cols

genSchema :: Gen Schema
genSchema :: Gen Schema
genSchema = (Int -> Gen Schema) -> Gen Schema
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen Schema) -> Gen Schema)
-> (Int -> Gen Schema) -> Gen Schema
forall a b. (a -> b) -> a -> b
$ \Int
tableNum -> do
  [TableName]
tableNames <- Int -> Gen TableName -> Gen [TableName]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
tableNum Gen TableName
genTableName
  Tables
tbls <- (Tables -> TableName -> Gen Tables)
-> Tables -> [TableName] -> Gen Tables
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (\Tables
acc TableName
tName -> (Table -> Tables -> Tables) -> Tables -> Table -> Tables
forall a b c. (a -> b -> c) -> b -> a -> c
flip (TableName -> Table -> Tables -> Tables
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert TableName
tName) Tables
acc (Table -> Tables) -> Gen Table -> Gen Tables
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tables -> Gen Table
genTable Tables
acc) Tables
forall a. Monoid a => a
mempty [TableName]
tableNames
  Schema -> Gen Schema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema -> Gen Schema) -> Schema -> Gen Schema
forall a b. (a -> b) -> a -> b
$ Tables -> Enumerations -> Sequences -> Schema
Schema Tables
tbls Enumerations
forall a. Monoid a => a
mempty Sequences
forall a. Monoid a => a
mempty

--
-- Generating Schema(s) which are not too dissimilar.
--

data TablesEditAction
  = AddTable
  | DropTable
  | ModifyTable
  | LeaveTableAlone

data TableEditAction
  = AddColumn
  | DropColumn
  | ModifyColumn
  | LeaveColumnAlone

data ColumnEditAction
  = ChangeType
  | ChangeConstraints
  | NoChange

-- Generate two 'Schema' which are not completely different but rather have /some/ differences.
genSimilarSchemas :: Gen (Schema, Schema)
genSimilarSchemas :: Gen (Schema, Schema)
genSimilarSchemas = do
  Schema
initialSchema <- Gen Schema
genSchema
  (Schema
initialSchema,) (Schema -> (Schema, Schema)) -> Gen Schema -> Gen (Schema, Schema)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tables -> Schema) -> Gen Tables -> Gen Schema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Tables
tbs -> Tables -> Enumerations -> Sequences -> Schema
Schema Tables
tbs Enumerations
forall a. Monoid a => a
mempty Sequences
forall a. Monoid a => a
mempty) (Tables -> Gen Tables
similarTables (Schema -> Tables
schemaTables Schema
initialSchema))

similarTables :: Tables -> Gen Tables
similarTables :: Tables -> Gen Tables
similarTables Tables
tbls = (StateT Tables Gen () -> Tables -> Gen Tables)
-> Tables -> StateT Tables Gen () -> Gen Tables
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Tables Gen () -> Tables -> Gen Tables
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT Tables
tbls (StateT Tables Gen () -> Gen Tables)
-> StateT Tables Gen () -> Gen Tables
forall a b. (a -> b) -> a -> b
$
  [(TableName, Table)]
-> ((TableName, Table) -> StateT Tables Gen ())
-> StateT Tables Gen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Tables -> [(TableName, Table)]
forall k a. Map k a -> [(k, a)]
M.toList Tables
tbls) (((TableName, Table) -> StateT Tables Gen ())
 -> StateT Tables Gen ())
-> ((TableName, Table) -> StateT Tables Gen ())
-> StateT Tables Gen ()
forall a b. (a -> b) -> a -> b
$ \(TableName
tName, Table
tbl) -> do
    TablesEditAction
tableEditAction <-
      Gen TablesEditAction -> StateT Tables Gen TablesEditAction
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen TablesEditAction -> StateT Tables Gen TablesEditAction)
-> Gen TablesEditAction -> StateT Tables Gen TablesEditAction
forall a b. (a -> b) -> a -> b
$
        [(Int, Gen TablesEditAction)] -> Gen TablesEditAction
forall a. [(Int, Gen a)] -> Gen a
frequency
          [ (Int
1, TablesEditAction -> Gen TablesEditAction
forall (f :: * -> *) a. Applicative f => a -> f a
pure TablesEditAction
AddTable),
            (Int
1, TablesEditAction -> Gen TablesEditAction
forall (f :: * -> *) a. Applicative f => a -> f a
pure TablesEditAction
DropTable),
            (Int
1, TablesEditAction -> Gen TablesEditAction
forall (f :: * -> *) a. Applicative f => a -> f a
pure TablesEditAction
ModifyTable),
            (Int
15, TablesEditAction -> Gen TablesEditAction
forall (f :: * -> *) a. Applicative f => a -> f a
pure TablesEditAction
LeaveTableAlone)
          ]
    case TablesEditAction
tableEditAction of
      TablesEditAction
AddTable -> do
        Tables
s <- StateT Tables Gen Tables
forall s (m :: * -> *). MonadState s m => m s
get
        TableName
newTableName <- Gen TableName -> StateT Tables Gen TableName
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen TableName
genTableName
        Table
newTable <- Gen Table -> StateT Tables Gen Table
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Table -> StateT Tables Gen Table)
-> Gen Table -> StateT Tables Gen Table
forall a b. (a -> b) -> a -> b
$ Tables -> Gen Table
genTable Tables
s
        (Tables -> Tables) -> StateT Tables Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (TableName -> Table -> Tables -> Tables
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert TableName
newTableName Table
newTable)
      TablesEditAction
DropTable -> (Tables -> Tables) -> StateT Tables Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (TableName -> Tables -> Tables
forall k a. Ord k => k -> Map k a -> Map k a
M.delete TableName
tName)
      TablesEditAction
ModifyTable -> do
        Table
table' <- Gen Table -> StateT Tables Gen Table
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Table -> StateT Tables Gen Table)
-> Gen Table -> StateT Tables Gen Table
forall a b. (a -> b) -> a -> b
$ Table -> Gen Table
similarTable Table
tbl
        (Tables -> Tables) -> StateT Tables Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (TableName -> Table -> Tables -> Tables
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert TableName
tName Table
table')
      TablesEditAction
LeaveTableAlone -> () -> StateT Tables Gen ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

similarTable :: Table -> Gen Table
similarTable :: Table -> Gen Table
similarTable Table
tbl = (StateT Table Gen () -> Table -> Gen Table)
-> Table -> StateT Table Gen () -> Gen Table
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Table Gen () -> Table -> Gen Table
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT Table
tbl (StateT Table Gen () -> Gen Table)
-> StateT Table Gen () -> Gen Table
forall a b. (a -> b) -> a -> b
$
  [(ColumnName, Column)]
-> ((ColumnName, Column) -> StateT Table Gen ())
-> StateT Table Gen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Columns -> [(ColumnName, Column)]
forall k a. Map k a -> [(k, a)]
M.toList (Columns -> [(ColumnName, Column)])
-> (Table -> Columns) -> Table -> [(ColumnName, Column)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table -> Columns
tableColumns (Table -> [(ColumnName, Column)])
-> Table -> [(ColumnName, Column)]
forall a b. (a -> b) -> a -> b
$ Table
tbl) (((ColumnName, Column) -> StateT Table Gen ())
 -> StateT Table Gen ())
-> ((ColumnName, Column) -> StateT Table Gen ())
-> StateT Table Gen ()
forall a b. (a -> b) -> a -> b
$ \(ColumnName
cName, Column
col) -> do
    TableEditAction
tableEditAction <-
      Gen TableEditAction -> StateT Table Gen TableEditAction
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen TableEditAction -> StateT Table Gen TableEditAction)
-> Gen TableEditAction -> StateT Table Gen TableEditAction
forall a b. (a -> b) -> a -> b
$
        [(Int, Gen TableEditAction)] -> Gen TableEditAction
forall a. [(Int, Gen a)] -> Gen a
frequency
          [ (Int
1, TableEditAction -> Gen TableEditAction
forall (f :: * -> *) a. Applicative f => a -> f a
pure TableEditAction
AddColumn),
            (Int
1, TableEditAction -> Gen TableEditAction
forall (f :: * -> *) a. Applicative f => a -> f a
pure TableEditAction
DropColumn),
            (Int
1, TableEditAction -> Gen TableEditAction
forall (f :: * -> *) a. Applicative f => a -> f a
pure TableEditAction
ModifyColumn),
            (Int
15, TableEditAction -> Gen TableEditAction
forall (f :: * -> *) a. Applicative f => a -> f a
pure TableEditAction
LeaveColumnAlone)
          ]
    case TableEditAction
tableEditAction of
      TableEditAction
AddColumn -> do
        Table
s <- StateT Table Gen Table
forall s (m :: * -> *). MonadState s m => m s
get
        ColumnName
newColumnName <- Gen ColumnName -> StateT Table Gen ColumnName
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen ColumnName
genColumnName
        Column
newColumn <- Gen Column -> StateT Table Gen Column
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Column -> StateT Table Gen Column)
-> Gen Column -> StateT Table Gen Column
forall a b. (a -> b) -> a -> b
$ Columns -> Gen Column
genColumn (Table -> Columns
tableColumns Table
s)
        (Table -> Table) -> StateT Table Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\Table
st -> Table
st {tableColumns :: Columns
tableColumns = ColumnName -> Column -> Columns -> Columns
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ColumnName
newColumnName Column
newColumn (Table -> Columns
tableColumns Table
st)})
      -- If we drop or modify a column we need to delete all constraints referencing that column.
      TableEditAction
DropColumn ->
        (Table -> Table) -> StateT Table Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify'
          ( \Table
st ->
              Table
st
                { tableColumns :: Columns
tableColumns = ColumnName -> Columns -> Columns
forall k a. Ord k => k -> Map k a -> Map k a
M.delete ColumnName
cName (Table -> Columns
tableColumns Table
st),
                  tableConstraints :: Set TableConstraint
tableConstraints = ColumnName -> Set TableConstraint -> Set TableConstraint
deleteConstraintReferencing ColumnName
cName (Table -> Set TableConstraint
tableConstraints Table
st)
                }
          )
      TableEditAction
ModifyColumn -> do
        Column
col' <- Gen Column -> StateT Table Gen Column
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Column -> StateT Table Gen Column)
-> Gen Column -> StateT Table Gen Column
forall a b. (a -> b) -> a -> b
$ Column -> Gen Column
similarColumn Column
col
        (Table -> Table) -> StateT Table Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify'
          ( \Table
st ->
              Table
st
                { tableColumns :: Columns
tableColumns = ColumnName -> Column -> Columns -> Columns
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ColumnName
cName Column
col' (Table -> Columns
tableColumns Table
st),
                  tableConstraints :: Set TableConstraint
tableConstraints = ColumnName -> Set TableConstraint -> Set TableConstraint
deleteConstraintReferencing ColumnName
cName (Table -> Set TableConstraint
tableConstraints Table
st)
                }
          )
      TableEditAction
LeaveColumnAlone -> () -> StateT Table Gen ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

deleteConstraintReferencing :: ColumnName -> Set TableConstraint -> Set TableConstraint
deleteConstraintReferencing :: ColumnName -> Set TableConstraint -> Set TableConstraint
deleteConstraintReferencing ColumnName
cName Set TableConstraint
conss = (TableConstraint -> Bool)
-> Set TableConstraint -> Set TableConstraint
forall a. (a -> Bool) -> Set a -> Set a
S.filter (Bool -> Bool
not (Bool -> Bool)
-> (TableConstraint -> Bool) -> TableConstraint -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableConstraint -> Bool
doesReference) Set TableConstraint
conss
  where
    doesReference :: TableConstraint -> Bool
    doesReference :: TableConstraint -> Bool
doesReference = \case
      PrimaryKey Text
_ Set ColumnName
refs -> ColumnName -> Set ColumnName -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member ColumnName
cName Set ColumnName
refs
      ForeignKey Text
_ TableName
_ Set (ColumnName, ColumnName)
refs ReferenceAction
_ ReferenceAction
_ -> let ours :: Set ColumnName
ours = ((ColumnName, ColumnName) -> ColumnName)
-> Set (ColumnName, ColumnName) -> Set ColumnName
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (ColumnName, ColumnName) -> ColumnName
forall a b. (a, b) -> b
snd Set (ColumnName, ColumnName)
refs in ColumnName -> Set ColumnName -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member ColumnName
cName Set ColumnName
ours
      Unique Text
_ Set ColumnName
refs -> ColumnName -> Set ColumnName -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member ColumnName
cName Set ColumnName
refs

similarColumn :: Column -> Gen Column
similarColumn :: Column -> Gen Column
similarColumn Column
col = do
  ColumnEditAction
editAction' <-
    [(Int, Gen ColumnEditAction)] -> Gen ColumnEditAction
forall a. [(Int, Gen a)] -> Gen a
frequency
      [ (Int
15, ColumnEditAction -> Gen ColumnEditAction
forall (f :: * -> *) a. Applicative f => a -> f a
pure ColumnEditAction
ChangeType),
        (Int
10, ColumnEditAction -> Gen ColumnEditAction
forall (f :: * -> *) a. Applicative f => a -> f a
pure ColumnEditAction
ChangeConstraints),
        (Int
30, ColumnEditAction -> Gen ColumnEditAction
forall (f :: * -> *) a. Applicative f => a -> f a
pure ColumnEditAction
NoChange)
      ]
  case ColumnEditAction
editAction' of
    ColumnEditAction
ChangeType -> do
      (ColumnType
newType, ColumnConstraint
newDef) <- Gen (ColumnType, ColumnConstraint)
genColumnType
      let oldConstraints :: Set ColumnConstraint
oldConstraints = (ColumnConstraint -> Bool)
-> Set ColumnConstraint -> Set ColumnConstraint
forall a. (a -> Bool) -> Set a -> Set a
S.filter (\ColumnConstraint
c -> case ColumnConstraint
c of Default Text
_ -> Bool
False; ColumnConstraint
_ -> Bool
True) (Column -> Set ColumnConstraint
columnConstraints Column
col)
      Column -> Gen Column
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Column -> Gen Column) -> Column -> Gen Column
forall a b. (a -> b) -> a -> b
$
        Column
col
          { columnType :: ColumnType
columnType = ColumnType
newType,
            columnConstraints :: Set ColumnConstraint
columnConstraints = ColumnConstraint -> Set ColumnConstraint -> Set ColumnConstraint
forall a. Ord a => a -> Set a -> Set a
S.insert ColumnConstraint
newDef Set ColumnConstraint
oldConstraints
          }
    ColumnEditAction
ChangeConstraints -> do
      -- At the moment we cannot add a new default value as we don't have a meanigful way of
      -- generating it.
      let oldConstraints :: Set ColumnConstraint
oldConstraints = Column -> Set ColumnConstraint
columnConstraints Column
col
      let newConstraints :: Set ColumnConstraint
newConstraints = case Set ColumnConstraint -> [ColumnConstraint]
forall a. Set a -> [a]
S.toList Set ColumnConstraint
oldConstraints of
            [] -> ColumnConstraint -> Set ColumnConstraint
forall a. a -> Set a
S.singleton ColumnConstraint
NotNull
            [ColumnConstraint
NotNull] -> Set ColumnConstraint
forall a. Monoid a => a
mempty
            [ColumnConstraint]
_ -> Set ColumnConstraint
oldConstraints
      Column -> Gen Column
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Column -> Gen Column) -> Column -> Gen Column
forall a b. (a -> b) -> a -> b
$ Column
col {columnConstraints :: Set ColumnConstraint
columnConstraints = Set ColumnConstraint
newConstraints}
    ColumnEditAction
NoChange -> Column -> Gen Column
forall (f :: * -> *) a. Applicative f => a -> f a
pure Column
col

--
-- Shrinking a Schema
--

shrinkSchema :: Schema -> [Schema]
shrinkSchema :: Schema -> [Schema]
shrinkSchema Schema
s =
  Schema
noSchema Schema -> [Schema] -> [Schema]
forall a. a -> [a] -> [a]
: ((TableName, Table) -> [Schema])
-> [(TableName, Table)] -> [Schema]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (TableName, Table) -> [Schema]
shrinkTable (Tables -> [(TableName, Table)]
forall k a. Map k a -> [(k, a)]
M.toList (Schema -> Tables
schemaTables Schema
s))
  where
    shrinkTable :: (TableName, Table) -> [Schema]
    shrinkTable :: (TableName, Table) -> [Schema]
shrinkTable (TableName
tName, Table
tbl) =
      Schema
s {schemaTables :: Tables
schemaTables = TableName -> Tables -> Tables
forall k a. Ord k => k -> Map k a -> Map k a
M.delete TableName
tName (Schema -> Tables
schemaTables Schema
s)} Schema -> [Schema] -> [Schema]
forall a. a -> [a] -> [a]
:
      ((ColumnName, Column) -> [Schema])
-> [(ColumnName, Column)] -> [Schema]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (TableName -> Table -> (ColumnName, Column) -> [Schema]
shrinkColumns TableName
tName Table
tbl) (Columns -> [(ColumnName, Column)]
forall k a. Map k a -> [(k, a)]
M.toList (Table -> Columns
tableColumns Table
tbl))

    shrinkColumns :: TableName -> Table -> (ColumnName, Column) -> [Schema]
    shrinkColumns :: TableName -> Table -> (ColumnName, Column) -> [Schema]
shrinkColumns TableName
tName Table
tbl (ColumnName
cName, Column
_col) =
      let tbl' :: Table
tbl' =
            Table
tbl
              { tableColumns :: Columns
tableColumns = ColumnName -> Columns -> Columns
forall k a. Ord k => k -> Map k a -> Map k a
M.delete ColumnName
cName (Table -> Columns
tableColumns Table
tbl),
                tableConstraints :: Set TableConstraint
tableConstraints = ColumnName -> Set TableConstraint -> Set TableConstraint
deleteConstraintReferencing ColumnName
cName (Table -> Set TableConstraint
tableConstraints Table
tbl)
              }
       in [Schema
s {schemaTables :: Tables
schemaTables = TableName -> Table -> Tables -> Tables
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert TableName
tName Table
tbl' (Schema -> Tables
schemaTables Schema
s)}]