Metadata.hs

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 { unDbCols :: Map PgColumnName (Either PgTypeRef PgPrimName) }
  deriving stock (Eq, Show, Generic)

newtype PrettyColMap =
  PrettyColMap { unPrettyColMap :: DbCols }
  deriving stock (Eq, Show, Generic)

instance Pretty PrettyColMap where
  pretty (PrettyColMap (DbCols cols)) =
    vsep (uncurry col <$> Map.toList cols)
    where
      col name = \case
        Right tpe -> "*" <+> pretty name <+> pretty tpe
        Left ref -> "+" <+> pretty name <+> pretty ref

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

tableColumns ::
  Monad m =>
  MigrationEffect m =>
  PgTableName ->
  m DbCols
tableColumns =
  typeColumns tableColumnsSql

columnMap :: [PgColumn] -> Map PgColumnName ColumnType
columnMap =
  Map.fromList . fmap \ PgColumn {name, pgType} -> (name, pgType)

logType ::
  MigrationEffect m =>
  Text ->
  DbCols ->
  DbCols ->
  m ()
logType desc dbCols colsByName =
  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 (Eq, Show, Generic)

typeStatus ::
  DbCols ->
  DbCols ->
  TypeStatus
typeStatus (DbCols dbCols) (DbCols colByName)
  | Map.null dbCols = Absent
  | dbCols == colByName = Match
  | otherwise = Mismatch