module Sqel.Migration.Metadata where

import qualified Data.Map.Strict as Map
import Exon (exon)
import Prettyprinter (Pretty, pretty, vsep, (<+>))

import qualified Sqel.Class.MigrationEffect as MigrationEffect
import Sqel.Class.MigrationEffect (MigrationEffect)
import qualified Sqel.Data.PgType as PgType
import Sqel.Data.PgType (
  ColumnType,
  PgColumn (PgColumn),
  PgColumnName (PgColumnName),
  PgPrimName (PgPrimName),
  PgTypeRef (PgTypeRef),
  )
import Sqel.Data.PgTypeName (PgTableName, pattern PgTypeName, PgTypeName)
import Sqel.Data.Sql (Sql)
import qualified Sqel.Statement as Statement
import Sqel.Statement (tableColumnsSql)

newtype DbCols =
  DbCols { DbCols -> Map PgColumnName (Either PgTypeRef PgPrimName)
unDbCols :: Map PgColumnName (Either PgTypeRef PgPrimName) }
  deriving stock (DbCols -> DbCols -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DbCols -> DbCols -> Bool
$c/= :: DbCols -> DbCols -> Bool
== :: DbCols -> DbCols -> Bool
$c== :: DbCols -> DbCols -> Bool
Eq, Int -> DbCols -> ShowS
[DbCols] -> ShowS
DbCols -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DbCols] -> ShowS
$cshowList :: [DbCols] -> ShowS
show :: DbCols -> String
$cshow :: DbCols -> String
showsPrec :: Int -> DbCols -> ShowS
$cshowsPrec :: Int -> DbCols -> ShowS
Show, forall x. Rep DbCols x -> DbCols
forall x. DbCols -> Rep DbCols x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DbCols x -> DbCols
$cfrom :: forall x. DbCols -> Rep DbCols x
Generic)

newtype PrettyColMap =
  PrettyColMap { PrettyColMap -> DbCols
unPrettyColMap :: DbCols }
  deriving stock (PrettyColMap -> PrettyColMap -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PrettyColMap -> PrettyColMap -> Bool
$c/= :: PrettyColMap -> PrettyColMap -> Bool
== :: PrettyColMap -> PrettyColMap -> Bool
$c== :: PrettyColMap -> PrettyColMap -> Bool
Eq, Int -> PrettyColMap -> ShowS
[PrettyColMap] -> ShowS
PrettyColMap -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PrettyColMap] -> ShowS
$cshowList :: [PrettyColMap] -> ShowS
show :: PrettyColMap -> String
$cshow :: PrettyColMap -> String
showsPrec :: Int -> PrettyColMap -> ShowS
$cshowsPrec :: Int -> PrettyColMap -> ShowS
Show, forall x. Rep PrettyColMap x -> PrettyColMap
forall x. PrettyColMap -> Rep PrettyColMap x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PrettyColMap x -> PrettyColMap
$cfrom :: forall x. PrettyColMap -> Rep PrettyColMap x
Generic)

instance Pretty PrettyColMap where
  pretty :: forall ann. PrettyColMap -> Doc ann
pretty (PrettyColMap (DbCols Map PgColumnName (Either PgTypeRef PgPrimName)
cols)) =
    forall ann. [Doc ann] -> Doc ann
vsep (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall {a} {a} {a} {ann}.
(Pretty a, Pretty a, Pretty a) =>
a -> Either a a -> Doc ann
col forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
Map.toList Map PgColumnName (Either PgTypeRef PgPrimName)
cols)
    where
      col :: a -> Either a a -> Doc ann
col a
name = \case
        Right a
tpe -> Doc ann
"*" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty a
name forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty a
tpe
        Left a
ref -> Doc ann
"+" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty a
name forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty a
ref

typeColumns ::
  Monad m =>
  MigrationEffect m =>
  Sql ->
  PgTypeName table ->
  m DbCols
typeColumns :: forall (m :: * -> *) (table :: Bool).
(Monad m, MigrationEffect m) =>
Sql -> PgTypeName table -> m DbCols
typeColumns Sql
code (PgTypeName Text
name) = do
  [(PgColumnName, Either PgTypeRef PgPrimName)]
cols <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Text, Text, Text, Maybe Text)
-> m (PgColumnName, Either PgTypeRef PgPrimName)
mktype forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) q a.
MigrationEffect m =>
q -> Statement q [a] -> m [a]
MigrationEffect.runStatement Text
name (Sql -> Statement Text [(Text, Text, Text, Maybe Text)]
Statement.dbColumns Sql
code)
  pure (Map PgColumnName (Either PgTypeRef PgPrimName) -> DbCols
DbCols (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PgColumnName, Either PgTypeRef PgPrimName)]
cols))
  where
    mktype :: (Text, Text, Text, Maybe Text)
-> m (PgColumnName, Either PgTypeRef PgPrimName)
mktype = \case
      (Text
col, Text
"USER-DEFINED", Text
n, Maybe Text
_) ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> PgColumnName
PgColumnName Text
col, forall a b. a -> Either a b
Left (Text -> PgTypeRef
PgTypeRef Text
n))
      (Text
col, Text
"ARRAY", Text
_, Just Text
n) ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> PgColumnName
PgColumnName Text
col, forall a b. b -> Either a b
Right (Text -> PgPrimName
PgPrimName [exon|#{n}[]|]))
      (Text
col, Text
n, Text
_, Maybe Text
Nothing) ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> PgColumnName
PgColumnName Text
col, forall a b. b -> Either a b
Right (Text -> PgPrimName
PgPrimName Text
n))
      (Text
col, Text
n, Text
_, Just Text
e) -> do
        forall (m :: * -> *). MigrationEffect m => Text -> m ()
MigrationEffect.error [exon|Error: non-array column with element type: ##{n} | ##{e}|]
        pure (Text -> PgColumnName
PgColumnName Text
col, forall a b. b -> Either a b
Right (Text -> PgPrimName
PgPrimName Text
n))

tableColumns ::
  Monad m =>
  MigrationEffect m =>
  PgTableName ->
  m DbCols
tableColumns :: forall (m :: * -> *).
(Monad m, MigrationEffect m) =>
PgTableName -> m DbCols
tableColumns =
  forall (m :: * -> *) (table :: Bool).
(Monad m, MigrationEffect m) =>
Sql -> PgTypeName table -> m DbCols
typeColumns Sql
tableColumnsSql

columnMap :: [PgColumn] -> Map PgColumnName ColumnType
columnMap :: [PgColumn] -> Map PgColumnName ColumnType
columnMap =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap \ PgColumn {PgColumnName
$sel:name:PgColumn :: PgColumn -> PgColumnName
name :: PgColumnName
name, ColumnType
$sel:pgType:PgColumn :: PgColumn -> ColumnType
pgType :: ColumnType
pgType} -> (PgColumnName
name, ColumnType
pgType)

logType ::
  MigrationEffect m =>
  Text ->
  DbCols ->
  DbCols ->
  m ()
logType :: forall (m :: * -> *).
MigrationEffect m =>
Text -> DbCols -> DbCols -> m ()
logType Text
desc DbCols
dbCols DbCols
colsByName =
  forall (m :: * -> *). MigrationEffect m => Text -> m ()
MigrationEffect.log [exon|Trying #{desc} with:
#{show (pretty (PrettyColMap colsByName))}
for existing #{desc} with
#{show (pretty (PrettyColMap dbCols))}|]

data TypeStatus =
  Absent
  |
  Mismatch
  |
  Match
  deriving stock (TypeStatus -> TypeStatus -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeStatus -> TypeStatus -> Bool
$c/= :: TypeStatus -> TypeStatus -> Bool
== :: TypeStatus -> TypeStatus -> Bool
$c== :: TypeStatus -> TypeStatus -> Bool
Eq, Int -> TypeStatus -> ShowS
[TypeStatus] -> ShowS
TypeStatus -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeStatus] -> ShowS
$cshowList :: [TypeStatus] -> ShowS
show :: TypeStatus -> String
$cshow :: TypeStatus -> String
showsPrec :: Int -> TypeStatus -> ShowS
$cshowsPrec :: Int -> TypeStatus -> ShowS
Show, forall x. Rep TypeStatus x -> TypeStatus
forall x. TypeStatus -> Rep TypeStatus x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TypeStatus x -> TypeStatus
$cfrom :: forall x. TypeStatus -> Rep TypeStatus x
Generic)

typeStatus ::
  DbCols ->
  DbCols ->
  TypeStatus
typeStatus :: DbCols -> DbCols -> TypeStatus
typeStatus (DbCols Map PgColumnName (Either PgTypeRef PgPrimName)
dbCols) (DbCols Map PgColumnName (Either PgTypeRef PgPrimName)
colByName)
  | forall k a. Map k a -> Bool
Map.null Map PgColumnName (Either PgTypeRef PgPrimName)
dbCols = TypeStatus
Absent
  | Map PgColumnName (Either PgTypeRef PgPrimName)
dbCols forall a. Eq a => a -> a -> Bool
== Map PgColumnName (Either PgTypeRef PgPrimName)
colByName = TypeStatus
Match
  | Bool
otherwise = TypeStatus
Mismatch