{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.Beam.AutoMigrate.Util where
import Control.Applicative.Lift
import Control.Monad.Except
import Data.Char
import Data.Functor.Constant
import Data.Set (Set)
import qualified Data.Set as Set
import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as T
import Database.Beam.AutoMigrate.Types (ColumnName(..), TableName(..))
import qualified Database.Beam.Schema as Beam
import Database.Beam.Schema.Tables
import Lens.Micro ((^.))
class HasColumnNames entity tbl where
colNames :: tbl (Beam.TableField tbl) -> (tbl (Beam.TableField tbl) -> entity) -> [ColumnName]
instance
Beam.Beamable (PrimaryKey tbl) =>
HasColumnNames (PrimaryKey tbl (Beam.TableField c)) tbl
where
colNames :: tbl (TableField tbl)
-> (tbl (TableField tbl) -> PrimaryKey tbl (TableField c))
-> [ColumnName]
colNames tbl (TableField tbl)
field tbl (TableField tbl) -> PrimaryKey tbl (TableField c)
fn = (Text -> ColumnName) -> [Text] -> [ColumnName]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ColumnName
ColumnName ((forall a. Columnar' (TableField c) a -> Text)
-> PrimaryKey tbl (TableField c) -> [Text]
forall (table :: (* -> *) -> *) (f :: * -> *) b.
Beamable table =>
(forall a. Columnar' f a -> b) -> table f -> [b]
allBeamValues (\(Columnar' Columnar (TableField c) a
x) -> Columnar (TableField c) a
TableField c a
x TableField c a -> Getting Text (TableField c a) Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text (TableField c a) Text
forall (table :: (* -> *) -> *) ty.
Lens' (TableField table ty) Text
fieldName) (tbl (TableField tbl) -> PrimaryKey tbl (TableField c)
fn tbl (TableField tbl)
field))
instance
Beam.Beamable (PrimaryKey tbl) =>
HasColumnNames (PrimaryKey tbl (Beam.TableField c)) tbl'
where
colNames :: tbl' (TableField tbl')
-> (tbl' (TableField tbl') -> PrimaryKey tbl (TableField c))
-> [ColumnName]
colNames tbl' (TableField tbl')
field tbl' (TableField tbl') -> PrimaryKey tbl (TableField c)
fn = (Text -> ColumnName) -> [Text] -> [ColumnName]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ColumnName
ColumnName ((forall a. Columnar' (TableField c) a -> Text)
-> PrimaryKey tbl (TableField c) -> [Text]
forall (table :: (* -> *) -> *) (f :: * -> *) b.
Beamable table =>
(forall a. Columnar' f a -> b) -> table f -> [b]
allBeamValues (\(Columnar' Columnar (TableField c) a
x) -> Columnar (TableField c) a
TableField c a
x TableField c a -> Getting Text (TableField c a) Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text (TableField c a) Text
forall (table :: (* -> *) -> *) ty.
Lens' (TableField table ty) Text
fieldName) (tbl' (TableField tbl') -> PrimaryKey tbl (TableField c)
fn tbl' (TableField tbl')
field))
instance HasColumnNames (Beam.TableField tbl ty) tbl where
colNames :: tbl (TableField tbl)
-> (tbl (TableField tbl) -> TableField tbl ty) -> [ColumnName]
colNames tbl (TableField tbl)
field tbl (TableField tbl) -> TableField tbl ty
fn = [Text -> ColumnName
ColumnName (tbl (TableField tbl) -> TableField tbl ty
fn tbl (TableField tbl)
field TableField tbl ty -> Getting Text (TableField tbl ty) Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text (TableField tbl ty) Text
forall (table :: (* -> *) -> *) ty.
Lens' (TableField table ty) Text
Beam.fieldName)]
tableSettings :: Beam.DatabaseEntity be db (TableEntity tbl) -> TableSettings tbl
tableSettings :: DatabaseEntity be db (TableEntity tbl) -> TableSettings tbl
tableSettings DatabaseEntity be db (TableEntity tbl)
entity = DatabaseEntityDescriptor be (TableEntity tbl) -> TableSettings tbl
forall be (tbl :: (* -> *) -> *).
DatabaseEntityDescriptor be (TableEntity tbl) -> TableSettings tbl
dbTableSettings (DatabaseEntityDescriptor be (TableEntity tbl)
-> TableSettings tbl)
-> DatabaseEntityDescriptor be (TableEntity tbl)
-> TableSettings tbl
forall a b. (a -> b) -> a -> b
$ DatabaseEntity be db (TableEntity tbl)
entity DatabaseEntity be db (TableEntity tbl)
-> Getting
(DatabaseEntityDescriptor be (TableEntity tbl))
(DatabaseEntity be db (TableEntity tbl))
(DatabaseEntityDescriptor be (TableEntity tbl))
-> DatabaseEntityDescriptor be (TableEntity tbl)
forall s a. s -> Getting a s a -> a
^. Getting
(DatabaseEntityDescriptor be (TableEntity tbl))
(DatabaseEntity be db (TableEntity tbl))
(DatabaseEntityDescriptor be (TableEntity tbl))
forall be (db :: (* -> *) -> *) entityType.
SimpleGetter
(DatabaseEntity be db entityType)
(DatabaseEntityDescriptor be entityType)
dbEntityDescriptor
tableName :: Beam.Beamable tbl => Beam.DatabaseEntity be db (TableEntity tbl) -> TableName
tableName :: DatabaseEntity be db (TableEntity tbl) -> TableName
tableName DatabaseEntity be db (TableEntity tbl)
entity = Text -> TableName
TableName (Text -> TableName) -> Text -> TableName
forall a b. (a -> b) -> a -> b
$ (DatabaseEntity be db (TableEntity tbl)
entity DatabaseEntity be db (TableEntity tbl)
-> Getting Text (DatabaseEntity be db (TableEntity tbl)) Text
-> Text
forall s a. s -> Getting a s a -> a
^. Getting
Text
(DatabaseEntity be db (TableEntity tbl))
(DatabaseEntityDescriptor be (TableEntity tbl))
forall be (db :: (* -> *) -> *) entityType.
SimpleGetter
(DatabaseEntity be db entityType)
(DatabaseEntityDescriptor be entityType)
dbEntityDescriptor Getting
Text
(DatabaseEntity be db (TableEntity tbl))
(DatabaseEntityDescriptor be (TableEntity tbl))
-> ((Text -> Const Text Text)
-> DatabaseEntityDescriptor be (TableEntity tbl)
-> Const Text (DatabaseEntityDescriptor be (TableEntity tbl)))
-> Getting Text (DatabaseEntity be db (TableEntity tbl)) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text)
-> DatabaseEntityDescriptor be (TableEntity tbl)
-> Const Text (DatabaseEntityDescriptor be (TableEntity tbl))
forall be entityType.
IsDatabaseEntity be entityType =>
Lens' (DatabaseEntityDescriptor be entityType) Text
dbEntityName)
pkFieldNames ::
(Beamable (PrimaryKey tbl), Beam.Table tbl) =>
Beam.DatabaseEntity be db (TableEntity tbl) ->
[ColumnName]
pkFieldNames :: DatabaseEntity be db (TableEntity tbl) -> [ColumnName]
pkFieldNames DatabaseEntity be db (TableEntity tbl)
entity =
(Text -> ColumnName) -> [Text] -> [ColumnName]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ColumnName
ColumnName ((forall a. Columnar' (TableField tbl) a -> Text)
-> PrimaryKey tbl (TableField tbl) -> [Text]
forall (table :: (* -> *) -> *) (f :: * -> *) b.
Beamable table =>
(forall a. Columnar' f a -> b) -> table f -> [b]
allBeamValues (\(Columnar' Columnar (TableField tbl) a
x) -> Columnar (TableField tbl) a
TableField tbl a
x TableField tbl a -> Getting Text (TableField tbl a) Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text (TableField tbl a) Text
forall (table :: (* -> *) -> *) ty.
Lens' (TableField table ty) Text
fieldName) (tbl (TableField tbl) -> PrimaryKey tbl (TableField tbl)
forall (table :: (* -> *) -> *) (column :: * -> *).
Table table =>
table column -> PrimaryKey table column
primaryKey (tbl (TableField tbl) -> PrimaryKey tbl (TableField tbl))
-> (DatabaseEntity be db (TableEntity tbl) -> tbl (TableField tbl))
-> DatabaseEntity be db (TableEntity tbl)
-> PrimaryKey tbl (TableField tbl)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatabaseEntity be db (TableEntity tbl) -> tbl (TableField tbl)
forall be (db :: (* -> *) -> *) (tbl :: (* -> *) -> *).
DatabaseEntity be db (TableEntity tbl) -> TableSettings tbl
tableSettings (DatabaseEntity be db (TableEntity tbl)
-> PrimaryKey tbl (TableField tbl))
-> DatabaseEntity be db (TableEntity tbl)
-> PrimaryKey tbl (TableField tbl)
forall a b. (a -> b) -> a -> b
$ DatabaseEntity be db (TableEntity tbl)
entity))
fieldAsColumnNames :: Beamable tbl => tbl (Beam.TableField c) -> [ColumnName]
fieldAsColumnNames :: tbl (TableField c) -> [ColumnName]
fieldAsColumnNames tbl (TableField c)
field = (Text -> ColumnName) -> [Text] -> [ColumnName]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ColumnName
ColumnName ((forall a. Columnar' (TableField c) a -> Text)
-> tbl (TableField c) -> [Text]
forall (table :: (* -> *) -> *) (f :: * -> *) b.
Beamable table =>
(forall a. Columnar' f a -> b) -> table f -> [b]
allBeamValues (\(Columnar' Columnar (TableField c) a
x) -> Columnar (TableField c) a
TableField c a
x TableField c a -> Getting Text (TableField c a) Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text (TableField c a) Text
forall (table :: (* -> *) -> *) ty.
Lens' (TableField table ty) Text
fieldName) tbl (TableField c)
field)
allColumnNames :: Beamable tbl => Beam.DatabaseEntity be db (TableEntity tbl) -> [ColumnName]
allColumnNames :: DatabaseEntity be db (TableEntity tbl) -> [ColumnName]
allColumnNames DatabaseEntity be db (TableEntity tbl)
entity =
let settings :: TableSettings tbl
settings = DatabaseEntityDescriptor be (TableEntity tbl) -> TableSettings tbl
forall be (tbl :: (* -> *) -> *).
DatabaseEntityDescriptor be (TableEntity tbl) -> TableSettings tbl
dbTableSettings (DatabaseEntityDescriptor be (TableEntity tbl)
-> TableSettings tbl)
-> DatabaseEntityDescriptor be (TableEntity tbl)
-> TableSettings tbl
forall a b. (a -> b) -> a -> b
$ DatabaseEntity be db (TableEntity tbl)
entity DatabaseEntity be db (TableEntity tbl)
-> Getting
(DatabaseEntityDescriptor be (TableEntity tbl))
(DatabaseEntity be db (TableEntity tbl))
(DatabaseEntityDescriptor be (TableEntity tbl))
-> DatabaseEntityDescriptor be (TableEntity tbl)
forall s a. s -> Getting a s a -> a
^. Getting
(DatabaseEntityDescriptor be (TableEntity tbl))
(DatabaseEntity be db (TableEntity tbl))
(DatabaseEntityDescriptor be (TableEntity tbl))
forall be (db :: (* -> *) -> *) entityType.
SimpleGetter
(DatabaseEntity be db entityType)
(DatabaseEntityDescriptor be entityType)
dbEntityDescriptor
in (Text -> ColumnName) -> [Text] -> [ColumnName]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ColumnName
ColumnName ((forall a. Columnar' (TableField tbl) a -> Text)
-> TableSettings tbl -> [Text]
forall (table :: (* -> *) -> *) (f :: * -> *) b.
Beamable table =>
(forall a. Columnar' f a -> b) -> table f -> [b]
allBeamValues (\(Columnar' Columnar (TableField tbl) a
x) -> Columnar (TableField tbl) a
TableField tbl a
x TableField tbl a -> Getting Text (TableField tbl a) Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text (TableField tbl a) Text
forall (table :: (* -> *) -> *) ty.
Lens' (TableField table ty) Text
fieldName) TableSettings tbl
settings)
hoistErrors :: Either e a -> Errors e a
hoistErrors :: Either e a -> Errors e a
hoistErrors Either e a
e =
case Either e a
e of
Left e
es ->
Constant e a -> Errors e a
forall (f :: * -> *) a. f a -> Lift f a
Other (e -> Constant e a
forall k a (b :: k). a -> Constant a b
Constant e
es)
Right a
a ->
a -> Errors e a
forall (f :: * -> *) a. a -> Lift f a
Pure a
a
sequenceEither :: (Monoid e, Traversable f) => f (Either e a) -> Either e (f a)
sequenceEither :: f (Either e a) -> Either e (f a)
sequenceEither =
Errors e (f a) -> Either e (f a)
forall e a. Errors e a -> Either e a
runErrors (Errors e (f a) -> Either e (f a))
-> (f (Either e a) -> Errors e (f a))
-> f (Either e a)
-> Either e (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either e a -> Lift (Constant e) a)
-> f (Either e a) -> Errors e (f a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Either e a -> Lift (Constant e) a
forall e a. Either e a -> Errors e a
hoistErrors
sequenceExceptT ::
(Monad m, Monoid w, Traversable t) =>
t (ExceptT w m a) ->
ExceptT w m (t a)
sequenceExceptT :: t (ExceptT w m a) -> ExceptT w m (t a)
sequenceExceptT t (ExceptT w m a)
es = do
t (Either w a)
es' <- m (t (Either w a)) -> ExceptT w m (t (Either w a))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((ExceptT w m a -> m (Either w a))
-> t (ExceptT w m a) -> m (t (Either w a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ExceptT w m a -> m (Either w a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT t (ExceptT w m a)
es)
m (Either w (t a)) -> ExceptT w m (t a)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Either w (t a) -> m (Either w (t a))
forall (m :: * -> *) a. Monad m => a -> m a
return (t (Either w a) -> Either w (t a)
forall e (f :: * -> *) a.
(Monoid e, Traversable f) =>
f (Either e a) -> Either e (f a)
sequenceEither t (Either w a)
es'))
sqlOptPrec :: Maybe Word -> Text
sqlOptPrec :: Maybe Word -> Text
sqlOptPrec Maybe Word
Nothing = Text
forall a. Monoid a => a
mempty
sqlOptPrec (Just Word
x) = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (Word -> String
forall a. Show a => a -> String
show Word
x) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
sqlOptCharSet :: Maybe Text -> Text
sqlOptCharSet :: Maybe Text -> Text
sqlOptCharSet Maybe Text
Nothing = Text
forall a. Monoid a => a
mempty
sqlOptCharSet (Just Text
cs) = Text
" CHARACTER SET " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cs
sqlEscaped :: Text -> Text
sqlEscaped :: Text -> Text
sqlEscaped Text
t = if Text -> Bool
sqlValidUnescaped Text
t
then Text
t
else
Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> [Text] -> Text
T.intercalate Text
"\"\"" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"\"" Text
t) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
sqlValidUnescaped :: Text -> Bool
sqlValidUnescaped :: Text -> Bool
sqlValidUnescaped Text
t = case Text -> Maybe (Char, Text)
T.uncons Text
t of
Maybe (Char, Text)
Nothing -> Bool
True
Just (Char
c, Text
rest) -> Char -> Bool
validUnescapedHead Char
c Bool -> Bool -> Bool
&& Text -> Bool
validUnescapedTail Text
rest Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
sqlIsReservedKeyword Text
t)
where
lowercase :: Char -> Bool
lowercase Char
c = Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
&& Char -> Bool
isLower Char
c
validUnescapedHead :: Char -> Bool
validUnescapedHead Char
c = Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"1234567890_"::String) Bool -> Bool -> Bool
|| Char -> Bool
lowercase Char
c
validUnescapedTail :: Text -> Bool
validUnescapedTail = (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all
(\Char
r -> Char -> Bool
lowercase Char
r Bool -> Bool -> Bool
|| Char
r Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"1234567890$_"::String)) (String -> Bool) -> (Text -> String) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
sqlIsReservedKeyword :: Text -> Bool
sqlIsReservedKeyword :: Text -> Bool
sqlIsReservedKeyword Text
t = Text -> Text
T.toCaseFold Text
t Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
postgresKeywordsReserved
postgresKeywordsReserved :: Set Text
postgresKeywordsReserved :: Set Text
postgresKeywordsReserved = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.toCaseFold
[ Text
"ALL"
, Text
"ANALYSE"
, Text
"ANALYZE"
, Text
"AND"
, Text
"ANY"
, Text
"ARRAY"
, Text
"AS"
, Text
"ASC"
, Text
"ASYMMETRIC"
, Text
"BOTH"
, Text
"CASE"
, Text
"CAST"
, Text
"CHECK"
, Text
"COLLATE"
, Text
"COLUMN"
, Text
"CONSTRAINT"
, Text
"CREATE"
, Text
"CURRENT_CATALOG"
, Text
"CURRENT_DATE"
, Text
"CURRENT_ROLE"
, Text
"CURRENT_TIME"
, Text
"CURRENT_TIMESTAMP"
, Text
"CURRENT_USER"
, Text
"DEFAULT"
, Text
"DEFERRABLE"
, Text
"DESC"
, Text
"DISTINCT"
, Text
"DO"
, Text
"ELSE"
, Text
"END"
, Text
"EXCEPT"
, Text
"FALSE"
, Text
"FETCH"
, Text
"FOR"
, Text
"FOREIGN"
, Text
"FROM"
, Text
"GRANT"
, Text
"GROUP"
, Text
"HAVING"
, Text
"IN"
, Text
"INITIALLY"
, Text
"INTERSECT"
, Text
"INTO"
, Text
"LATERAL"
, Text
"LEADING"
, Text
"LIMIT"
, Text
"LOCALTIME"
, Text
"LOCALTIMESTAMP"
, Text
"NOT"
, Text
"NULL"
, Text
"OFFSET"
, Text
"ON"
, Text
"ONLY"
, Text
"OR"
, Text
"ORDER"
, Text
"PLACING"
, Text
"PRIMARY"
, Text
"REFERENCES"
, Text
"RETURNING"
, Text
"SELECT"
, Text
"SESSION_USER"
, Text
"SOME"
, Text
"SYMMETRIC"
, Text
"TABLE"
, Text
"THEN"
, Text
"TO"
, Text
"TRAILING"
, Text
"TRUE"
, Text
"UNION"
, Text
"UNIQUE"
, Text
"USER"
, Text
"USING"
, Text
"VARIADIC"
, Text
"WHEN"
, Text
"WHERE"
, Text
"WINDOW"
, Text
"WITH"
]
sqlSingleQuoted :: Text -> Text
sqlSingleQuoted :: Text -> Text
sqlSingleQuoted Text
t = Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
sqlOptNumericPrec :: Maybe (Word, Maybe Word) -> Text
sqlOptNumericPrec :: Maybe (Word, Maybe Word) -> Text
sqlOptNumericPrec Maybe (Word, Maybe Word)
Nothing = Text
forall a. Monoid a => a
mempty
sqlOptNumericPrec (Just (Word
prec, Maybe Word
Nothing)) = Maybe Word -> Text
sqlOptPrec (Word -> Maybe Word
forall a. a -> Maybe a
Just Word
prec)
sqlOptNumericPrec (Just (Word
prec, Just Word
dec)) = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (Word -> String
forall a. Show a => a -> String
show Word
prec) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (Word -> String
forall a. Show a => a -> String
show Word
dec) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"