{-# language BlockArguments #-}
{-# language LambdaCase #-}
{-# language RecordWildCards #-}
{-# language RankNTypes #-}
{-# language DuplicateRecordFields #-}
{-# language DerivingStrategies #-}
{-# language OverloadedRecordDot #-}
{-# language TypeApplications #-}
{-# language NamedFieldPuns #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneDeriving #-}
{-# language DeriveAnyClass #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language DeriveGeneric #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language OverloadedStrings #-}
{-# language GADTs #-}

module Rel8.Table.Verify
    ( getSchemaErrors
    , SomeTableSchema(..)
    , showCreateTable
    , checkedShowCreateTable
    ) where

-- base
import Control.Monad
import Data.Bits (shiftR, (.&.))
import Data.Either (lefts)
import Data.Function
import Data.Functor ((<&>))
import Data.Functor.Const
import Data.Functor.Contravariant ( (>$<) )
import Data.Int ( Int16, Int64 )
import qualified Data.List as L
import Data.List.NonEmpty ( NonEmpty((:|)) )
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (isJust, mapMaybe)
import Data.Text ( Text )
import qualified Data.Text as T
import GHC.Generics
import Prelude hiding ( filter )
import qualified Prelude as P

-- containers
import qualified Data.Map as M

-- hasql
import Hasql.Connection
import qualified Hasql.Statement as HS

-- rel8
import Rel8 -- not importing this seems to cause a type error???
import Rel8.Column ( Column )
import Rel8.Column.List ( HList )
import Rel8.Expr ( Expr )
import Rel8.Generic.Rel8able (GFromExprs, Rel8able)
import Rel8.Query ( Query )
import Rel8.Schema.HTable
import Rel8.Schema.Name ( Name(Name) )
import Rel8.Schema.Null hiding (nullable)
import qualified Rel8.Schema.Null as Null
import qualified Rel8.Statement.Run as RSR
import Rel8.Schema.Table ( TableSchema(..) )
import Rel8.Schema.Spec
import Rel8.Schema.Result ( Result )
import Rel8.Schema.QualifiedName ( QualifiedName(..) )
import Rel8.Table ( Columns )
import Rel8.Table.List ( ListTable )
import Rel8.Table.Serialize ( ToExprs )
import Rel8.Type ( DBType(..) )
import Rel8.Type.Eq ( DBEq )
import Rel8.Type.Name ( TypeName(..) )

-- these
import Data.These


data Relkind
    = OrdinaryTable
    | Index
    | Sequence
    | ToastTable
    | View
    | MaterializedView
    | CompositeType
    | ForeignTable
    | PartitionedTable
    | PartitionedIndex
  deriving stock (Int -> Relkind -> ShowS
[Relkind] -> ShowS
Relkind -> String
(Int -> Relkind -> ShowS)
-> (Relkind -> String) -> ([Relkind] -> ShowS) -> Show Relkind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Relkind -> ShowS
showsPrec :: Int -> Relkind -> ShowS
$cshow :: Relkind -> String
show :: Relkind -> String
$cshowList :: [Relkind] -> ShowS
showList :: [Relkind] -> ShowS
Show)
  deriving anyclass (DBType Relkind
DBType Relkind => DBEq Relkind
forall a. DBType a => DBEq a
DBEq)

instance DBType Relkind where
  typeInformation :: TypeInformation Relkind
typeInformation = (Text -> Either String Relkind)
-> (Relkind -> Text)
-> TypeInformation Text
-> TypeInformation Relkind
forall a b.
(a -> Either String b)
-> (b -> a) -> TypeInformation a -> TypeInformation b
parseTypeInformation Text -> Either String Relkind
parser Relkind -> Text
printer TypeInformation Text
forall a. DBType a => TypeInformation a
typeInformation
    where
      parser :: Text -> Either String Relkind
parser = \case
        Text
"r"         -> Relkind -> Either String Relkind
forall a. a -> Either String a
forall (f :: Context) a. Applicative f => a -> f a
pure Relkind
OrdinaryTable
        Text
"i"         -> Relkind -> Either String Relkind
forall a. a -> Either String a
forall (f :: Context) a. Applicative f => a -> f a
pure Relkind
Index
        Text
"S"         -> Relkind -> Either String Relkind
forall a. a -> Either String a
forall (f :: Context) a. Applicative f => a -> f a
pure Relkind
Sequence
        Text
"t"         -> Relkind -> Either String Relkind
forall a. a -> Either String a
forall (f :: Context) a. Applicative f => a -> f a
pure Relkind
ToastTable
        Text
"v"         -> Relkind -> Either String Relkind
forall a. a -> Either String a
forall (f :: Context) a. Applicative f => a -> f a
pure Relkind
View
        Text
"m"         -> Relkind -> Either String Relkind
forall a. a -> Either String a
forall (f :: Context) a. Applicative f => a -> f a
pure Relkind
MaterializedView
        Text
"c"         -> Relkind -> Either String Relkind
forall a. a -> Either String a
forall (f :: Context) a. Applicative f => a -> f a
pure Relkind
CompositeType
        Text
"f"         -> Relkind -> Either String Relkind
forall a. a -> Either String a
forall (f :: Context) a. Applicative f => a -> f a
pure Relkind
ForeignTable
        Text
"p"         -> Relkind -> Either String Relkind
forall a. a -> Either String a
forall (f :: Context) a. Applicative f => a -> f a
pure Relkind
PartitionedTable
        Text
"I"         -> Relkind -> Either String Relkind
forall a. a -> Either String a
forall (f :: Context) a. Applicative f => a -> f a
pure Relkind
PartitionedIndex
        (Text
x :: Text) -> String -> Either String Relkind
forall a b. a -> Either a b
Left (String -> Either String Relkind)
-> String -> Either String Relkind
forall a b. (a -> b) -> a -> b
$ String
"Unknown relkind: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
x

      printer :: Relkind -> Text
printer = \case
        Relkind
OrdinaryTable -> Text
"r"
        Relkind
Index -> Text
"i"
        Relkind
Sequence -> Text
"S"
        Relkind
ToastTable -> Text
"t"
        Relkind
View -> Text
"v"
        Relkind
MaterializedView -> Text
"m"
        Relkind
CompositeType -> Text
"c"
        Relkind
ForeignTable -> Text
"f"
        Relkind
PartitionedTable -> Text
"p"
        Relkind
PartitionedIndex -> Text
"I"

newtype Oid = Oid Int64
  deriving newtype (NotNull Oid
TypeInformation Oid
NotNull Oid => TypeInformation Oid -> DBType Oid
forall a. NotNull a => TypeInformation a -> DBType a
$ctypeInformation :: TypeInformation Oid
typeInformation :: TypeInformation Oid
DBType, DBType Oid
DBType Oid => DBEq Oid
forall a. DBType a => DBEq a
DBEq, Int -> Oid -> ShowS
[Oid] -> ShowS
Oid -> String
(Int -> Oid -> ShowS)
-> (Oid -> String) -> ([Oid] -> ShowS) -> Show Oid
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Oid -> ShowS
showsPrec :: Int -> Oid -> ShowS
$cshow :: Oid -> String
show :: Oid -> String
$cshowList :: [Oid] -> ShowS
showList :: [Oid] -> ShowS
Show)

data PGClass f = PGClass
  { forall (f :: Context). PGClass f -> Column f Oid
oid :: Column f Oid
  , forall (f :: Context). PGClass f -> Column f Text
relname :: Column f Text
  , forall (f :: Context). PGClass f -> Column f Relkind
relkind :: Column f Relkind
  , forall (f :: Context). PGClass f -> Column f Oid
relnamespace :: Column f Oid
  }
  deriving stock ((forall x. PGClass f -> Rep (PGClass f) x)
-> (forall x. Rep (PGClass f) x -> PGClass f)
-> Generic (PGClass f)
forall x. Rep (PGClass f) x -> PGClass f
forall x. PGClass f -> Rep (PGClass f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: Context) x. Rep (PGClass f) x -> PGClass f
forall (f :: Context) x. PGClass f -> Rep (PGClass f) x
$cfrom :: forall (f :: Context) x. PGClass f -> Rep (PGClass f) x
from :: forall x. PGClass f -> Rep (PGClass f) x
$cto :: forall (f :: Context) x. Rep (PGClass f) x -> PGClass f
to :: forall x. Rep (PGClass f) x -> PGClass f
Generic)
  deriving anyclass (HTable (GColumns PGClass)
HTable (GColumns PGClass) =>
(forall (context :: Context).
 SContext context -> GColumns PGClass context -> PGClass context)
-> (forall (context :: Context).
    SContext context -> PGClass context -> GColumns PGClass context)
-> (GColumns PGClass Result -> GFromExprs PGClass)
-> (GFromExprs PGClass -> GColumns PGClass Result)
-> Rel8able PGClass
GColumns PGClass Result -> GFromExprs PGClass
GFromExprs PGClass -> GColumns PGClass Result
forall (context :: Context).
SContext context -> GColumns PGClass context -> PGClass context
forall (context :: Context).
SContext context -> PGClass context -> GColumns PGClass context
forall (t :: HTable).
HTable (GColumns t) =>
(forall (context :: Context).
 SContext context -> GColumns t context -> t context)
-> (forall (context :: Context).
    SContext context -> t context -> GColumns t context)
-> (GColumns t Result -> GFromExprs t)
-> (GFromExprs t -> GColumns t Result)
-> Rel8able t
$cgfromColumns :: forall (context :: Context).
SContext context -> GColumns PGClass context -> PGClass context
gfromColumns :: forall (context :: Context).
SContext context -> GColumns PGClass context -> PGClass context
$cgtoColumns :: forall (context :: Context).
SContext context -> PGClass context -> GColumns PGClass context
gtoColumns :: forall (context :: Context).
SContext context -> PGClass context -> GColumns PGClass context
$cgfromResult :: GColumns PGClass Result -> GFromExprs PGClass
gfromResult :: GColumns PGClass Result -> GFromExprs PGClass
$cgtoResult :: GFromExprs PGClass -> GColumns PGClass Result
gtoResult :: GFromExprs PGClass -> GColumns PGClass Result
Rel8able)

deriving stock instance Show (PGClass Result)

pgclass :: TableSchema (PGClass Name)
pgclass :: TableSchema (PGClass Name)
pgclass = TableSchema
  { name :: QualifiedName
name = String -> Maybe String -> QualifiedName
QualifiedName String
"pg_class" (String -> Maybe String
forall a. a -> Maybe a
Just String
"pg_catalog")
  , columns :: PGClass Name
columns = (NonEmpty String -> String) -> PGClass Name
forall a. Table Name a => (NonEmpty String -> String) -> a
namesFromLabelsWith NonEmpty String -> String
forall a. NonEmpty a -> a
NonEmpty.last
  }

data PGAttribute f = PGAttribute
  { forall (f :: Context). PGAttribute f -> Column f Oid
attrelid :: Column f Oid
  , forall (f :: Context). PGAttribute f -> Column f Text
attname :: Column f Text
  , forall (f :: Context). PGAttribute f -> Column f Oid
atttypid :: Column f Oid
  , forall (f :: Context). PGAttribute f -> Column f Int64
attnum :: Column f Int64
  , forall (f :: Context). PGAttribute f -> Column f Int64
atttypmod :: Column f Int64
  , forall (f :: Context). PGAttribute f -> Column f Bool
attnotnull :: Column f Bool
  , forall (f :: Context). PGAttribute f -> Column f Int16
attndims :: Column f Int16
  }
  deriving stock ((forall x. PGAttribute f -> Rep (PGAttribute f) x)
-> (forall x. Rep (PGAttribute f) x -> PGAttribute f)
-> Generic (PGAttribute f)
forall x. Rep (PGAttribute f) x -> PGAttribute f
forall x. PGAttribute f -> Rep (PGAttribute f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: Context) x. Rep (PGAttribute f) x -> PGAttribute f
forall (f :: Context) x. PGAttribute f -> Rep (PGAttribute f) x
$cfrom :: forall (f :: Context) x. PGAttribute f -> Rep (PGAttribute f) x
from :: forall x. PGAttribute f -> Rep (PGAttribute f) x
$cto :: forall (f :: Context) x. Rep (PGAttribute f) x -> PGAttribute f
to :: forall x. Rep (PGAttribute f) x -> PGAttribute f
Generic)
  deriving anyclass (HTable (GColumns PGAttribute)
HTable (GColumns PGAttribute) =>
(forall (context :: Context).
 SContext context
 -> GColumns PGAttribute context -> PGAttribute context)
-> (forall (context :: Context).
    SContext context
    -> PGAttribute context -> GColumns PGAttribute context)
-> (GColumns PGAttribute Result -> GFromExprs PGAttribute)
-> (GFromExprs PGAttribute -> GColumns PGAttribute Result)
-> Rel8able PGAttribute
GColumns PGAttribute Result -> GFromExprs PGAttribute
GFromExprs PGAttribute -> GColumns PGAttribute Result
forall (context :: Context).
SContext context
-> GColumns PGAttribute context -> PGAttribute context
forall (context :: Context).
SContext context
-> PGAttribute context -> GColumns PGAttribute context
forall (t :: HTable).
HTable (GColumns t) =>
(forall (context :: Context).
 SContext context -> GColumns t context -> t context)
-> (forall (context :: Context).
    SContext context -> t context -> GColumns t context)
-> (GColumns t Result -> GFromExprs t)
-> (GFromExprs t -> GColumns t Result)
-> Rel8able t
$cgfromColumns :: forall (context :: Context).
SContext context
-> GColumns PGAttribute context -> PGAttribute context
gfromColumns :: forall (context :: Context).
SContext context
-> GColumns PGAttribute context -> PGAttribute context
$cgtoColumns :: forall (context :: Context).
SContext context
-> PGAttribute context -> GColumns PGAttribute context
gtoColumns :: forall (context :: Context).
SContext context
-> PGAttribute context -> GColumns PGAttribute context
$cgfromResult :: GColumns PGAttribute Result -> GFromExprs PGAttribute
gfromResult :: GColumns PGAttribute Result -> GFromExprs PGAttribute
$cgtoResult :: GFromExprs PGAttribute -> GColumns PGAttribute Result
gtoResult :: GFromExprs PGAttribute -> GColumns PGAttribute Result
Rel8able)

deriving stock instance Show (PGAttribute Result)

pgattribute :: TableSchema (PGAttribute Name)
pgattribute :: TableSchema (PGAttribute Name)
pgattribute = TableSchema
  { name :: QualifiedName
name = String -> Maybe String -> QualifiedName
QualifiedName String
"pg_attribute" (String -> Maybe String
forall a. a -> Maybe a
Just String
"pg_catalog")
  , columns :: PGAttribute Name
columns = (NonEmpty String -> String) -> PGAttribute Name
forall a. Table Name a => (NonEmpty String -> String) -> a
namesFromLabelsWith NonEmpty String -> String
forall a. NonEmpty a -> a
NonEmpty.last
  }

data PGType f = PGType
  { forall (f :: Context). PGType f -> Column f Oid
oid :: Column f Oid
  , forall (f :: Context). PGType f -> Column f Text
typname :: Column f Text
  , forall (f :: Context). PGType f -> Column f Oid
typnamespace :: Column f Oid
  }
  deriving stock ((forall x. PGType f -> Rep (PGType f) x)
-> (forall x. Rep (PGType f) x -> PGType f) -> Generic (PGType f)
forall x. Rep (PGType f) x -> PGType f
forall x. PGType f -> Rep (PGType f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: Context) x. Rep (PGType f) x -> PGType f
forall (f :: Context) x. PGType f -> Rep (PGType f) x
$cfrom :: forall (f :: Context) x. PGType f -> Rep (PGType f) x
from :: forall x. PGType f -> Rep (PGType f) x
$cto :: forall (f :: Context) x. Rep (PGType f) x -> PGType f
to :: forall x. Rep (PGType f) x -> PGType f
Generic)
  deriving anyclass (HTable (GColumns PGType)
HTable (GColumns PGType) =>
(forall (context :: Context).
 SContext context -> GColumns PGType context -> PGType context)
-> (forall (context :: Context).
    SContext context -> PGType context -> GColumns PGType context)
-> (GColumns PGType Result -> GFromExprs PGType)
-> (GFromExprs PGType -> GColumns PGType Result)
-> Rel8able PGType
GColumns PGType Result -> GFromExprs PGType
GFromExprs PGType -> GColumns PGType Result
forall (context :: Context).
SContext context -> GColumns PGType context -> PGType context
forall (context :: Context).
SContext context -> PGType context -> GColumns PGType context
forall (t :: HTable).
HTable (GColumns t) =>
(forall (context :: Context).
 SContext context -> GColumns t context -> t context)
-> (forall (context :: Context).
    SContext context -> t context -> GColumns t context)
-> (GColumns t Result -> GFromExprs t)
-> (GFromExprs t -> GColumns t Result)
-> Rel8able t
$cgfromColumns :: forall (context :: Context).
SContext context -> GColumns PGType context -> PGType context
gfromColumns :: forall (context :: Context).
SContext context -> GColumns PGType context -> PGType context
$cgtoColumns :: forall (context :: Context).
SContext context -> PGType context -> GColumns PGType context
gtoColumns :: forall (context :: Context).
SContext context -> PGType context -> GColumns PGType context
$cgfromResult :: GColumns PGType Result -> GFromExprs PGType
gfromResult :: GColumns PGType Result -> GFromExprs PGType
$cgtoResult :: GFromExprs PGType -> GColumns PGType Result
gtoResult :: GFromExprs PGType -> GColumns PGType Result
Rel8able)

deriving stock instance Show (PGType Result)

pgtype :: TableSchema (PGType Name)
pgtype :: TableSchema (PGType Name)
pgtype = TableSchema
  { name :: QualifiedName
name = String -> Maybe String -> QualifiedName
QualifiedName String
"pg_type" (String -> Maybe String
forall a. a -> Maybe a
Just String
"pg_catalog")
  , columns :: PGType Name
columns = (NonEmpty String -> String) -> PGType Name
forall a. Table Name a => (NonEmpty String -> String) -> a
namesFromLabelsWith NonEmpty String -> String
forall a. NonEmpty a -> a
NonEmpty.last
  }

data PGNamespace f = PGNamespace
  { forall (f :: Context). PGNamespace f -> Column f Oid
oid :: Column f Oid
  , forall (f :: Context). PGNamespace f -> Column f Text
nspname :: Column f Text
  }
  deriving stock ((forall x. PGNamespace f -> Rep (PGNamespace f) x)
-> (forall x. Rep (PGNamespace f) x -> PGNamespace f)
-> Generic (PGNamespace f)
forall x. Rep (PGNamespace f) x -> PGNamespace f
forall x. PGNamespace f -> Rep (PGNamespace f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: Context) x. Rep (PGNamespace f) x -> PGNamespace f
forall (f :: Context) x. PGNamespace f -> Rep (PGNamespace f) x
$cfrom :: forall (f :: Context) x. PGNamespace f -> Rep (PGNamespace f) x
from :: forall x. PGNamespace f -> Rep (PGNamespace f) x
$cto :: forall (f :: Context) x. Rep (PGNamespace f) x -> PGNamespace f
to :: forall x. Rep (PGNamespace f) x -> PGNamespace f
Generic)
  deriving anyclass (HTable (GColumns PGNamespace)
HTable (GColumns PGNamespace) =>
(forall (context :: Context).
 SContext context
 -> GColumns PGNamespace context -> PGNamespace context)
-> (forall (context :: Context).
    SContext context
    -> PGNamespace context -> GColumns PGNamespace context)
-> (GColumns PGNamespace Result -> GFromExprs PGNamespace)
-> (GFromExprs PGNamespace -> GColumns PGNamespace Result)
-> Rel8able PGNamespace
GColumns PGNamespace Result -> GFromExprs PGNamespace
GFromExprs PGNamespace -> GColumns PGNamespace Result
forall (context :: Context).
SContext context
-> GColumns PGNamespace context -> PGNamespace context
forall (context :: Context).
SContext context
-> PGNamespace context -> GColumns PGNamespace context
forall (t :: HTable).
HTable (GColumns t) =>
(forall (context :: Context).
 SContext context -> GColumns t context -> t context)
-> (forall (context :: Context).
    SContext context -> t context -> GColumns t context)
-> (GColumns t Result -> GFromExprs t)
-> (GFromExprs t -> GColumns t Result)
-> Rel8able t
$cgfromColumns :: forall (context :: Context).
SContext context
-> GColumns PGNamespace context -> PGNamespace context
gfromColumns :: forall (context :: Context).
SContext context
-> GColumns PGNamespace context -> PGNamespace context
$cgtoColumns :: forall (context :: Context).
SContext context
-> PGNamespace context -> GColumns PGNamespace context
gtoColumns :: forall (context :: Context).
SContext context
-> PGNamespace context -> GColumns PGNamespace context
$cgfromResult :: GColumns PGNamespace Result -> GFromExprs PGNamespace
gfromResult :: GColumns PGNamespace Result -> GFromExprs PGNamespace
$cgtoResult :: GFromExprs PGNamespace -> GColumns PGNamespace Result
gtoResult :: GFromExprs PGNamespace -> GColumns PGNamespace Result
Rel8able)

deriving stock instance Show (PGNamespace Result)

pgnamespace :: TableSchema (PGNamespace Name)
pgnamespace :: TableSchema (PGNamespace Name)
pgnamespace = TableSchema
  { name :: QualifiedName
name = String -> Maybe String -> QualifiedName
QualifiedName String
"pg_namespace" (String -> Maybe String
forall a. a -> Maybe a
Just String
"pg_catalog")
  , columns :: PGNamespace Name
columns = (NonEmpty String -> String) -> PGNamespace Name
forall a. Table Name a => (NonEmpty String -> String) -> a
namesFromLabelsWith NonEmpty String -> String
forall a. NonEmpty a -> a
NonEmpty.last
  }

data PGCast f = PGCast
  { forall (f :: Context). PGCast f -> Column f Oid
oid :: Column f Oid
  , forall (f :: Context). PGCast f -> Column f Oid
castsource :: Column f Oid
  , forall (f :: Context). PGCast f -> Column f Oid
casttarget :: Column f Oid
  , forall (f :: Context). PGCast f -> Column f Oid
castfunc :: Column f Oid
  , forall (f :: Context). PGCast f -> Column f Text
castcontext :: Column f Text -- Char
  , forall (f :: Context). PGCast f -> Column f Char
castmethod :: Column f Char
  }
  deriving stock ((forall x. PGCast f -> Rep (PGCast f) x)
-> (forall x. Rep (PGCast f) x -> PGCast f) -> Generic (PGCast f)
forall x. Rep (PGCast f) x -> PGCast f
forall x. PGCast f -> Rep (PGCast f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: Context) x. Rep (PGCast f) x -> PGCast f
forall (f :: Context) x. PGCast f -> Rep (PGCast f) x
$cfrom :: forall (f :: Context) x. PGCast f -> Rep (PGCast f) x
from :: forall x. PGCast f -> Rep (PGCast f) x
$cto :: forall (f :: Context) x. Rep (PGCast f) x -> PGCast f
to :: forall x. Rep (PGCast f) x -> PGCast f
Generic)
  deriving anyclass (HTable (GColumns PGCast)
HTable (GColumns PGCast) =>
(forall (context :: Context).
 SContext context -> GColumns PGCast context -> PGCast context)
-> (forall (context :: Context).
    SContext context -> PGCast context -> GColumns PGCast context)
-> (GColumns PGCast Result -> GFromExprs PGCast)
-> (GFromExprs PGCast -> GColumns PGCast Result)
-> Rel8able PGCast
GColumns PGCast Result -> GFromExprs PGCast
GFromExprs PGCast -> GColumns PGCast Result
forall (context :: Context).
SContext context -> GColumns PGCast context -> PGCast context
forall (context :: Context).
SContext context -> PGCast context -> GColumns PGCast context
forall (t :: HTable).
HTable (GColumns t) =>
(forall (context :: Context).
 SContext context -> GColumns t context -> t context)
-> (forall (context :: Context).
    SContext context -> t context -> GColumns t context)
-> (GColumns t Result -> GFromExprs t)
-> (GFromExprs t -> GColumns t Result)
-> Rel8able t
$cgfromColumns :: forall (context :: Context).
SContext context -> GColumns PGCast context -> PGCast context
gfromColumns :: forall (context :: Context).
SContext context -> GColumns PGCast context -> PGCast context
$cgtoColumns :: forall (context :: Context).
SContext context -> PGCast context -> GColumns PGCast context
gtoColumns :: forall (context :: Context).
SContext context -> PGCast context -> GColumns PGCast context
$cgfromResult :: GColumns PGCast Result -> GFromExprs PGCast
gfromResult :: GColumns PGCast Result -> GFromExprs PGCast
$cgtoResult :: GFromExprs PGCast -> GColumns PGCast Result
gtoResult :: GFromExprs PGCast -> GColumns PGCast Result
Rel8able)

deriving stock instance Show (PGCast Result)

pgcast :: TableSchema (PGCast Name)
pgcast :: TableSchema (PGCast Name)
pgcast = TableSchema
  { name :: QualifiedName
name = String -> Maybe String -> QualifiedName
QualifiedName String
"pg_cast" (String -> Maybe String
forall a. a -> Maybe a
Just String
"pg_catalog")
  , columns :: PGCast Name
columns = (NonEmpty String -> String) -> PGCast Name
forall a. Table Name a => (NonEmpty String -> String) -> a
namesFromLabelsWith NonEmpty String -> String
forall a. NonEmpty a -> a
NonEmpty.last
  }

data PGTable f = PGTable
  { forall (f :: Context). PGTable f -> Column f Text
name :: Column f Text
  , forall (f :: Context). PGTable f -> HList f (Attribute f)
columns :: HList f (Attribute f)
  }
  deriving stock ((forall x. PGTable f -> Rep (PGTable f) x)
-> (forall x. Rep (PGTable f) x -> PGTable f)
-> Generic (PGTable f)
forall x. Rep (PGTable f) x -> PGTable f
forall x. PGTable f -> Rep (PGTable f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: Context) x. Rep (PGTable f) x -> PGTable f
forall (f :: Context) x. PGTable f -> Rep (PGTable f) x
$cfrom :: forall (f :: Context) x. PGTable f -> Rep (PGTable f) x
from :: forall x. PGTable f -> Rep (PGTable f) x
$cto :: forall (f :: Context) x. Rep (PGTable f) x -> PGTable f
to :: forall x. Rep (PGTable f) x -> PGTable f
Generic)
  deriving anyclass (HTable (GColumns PGTable)
HTable (GColumns PGTable) =>
(forall (context :: Context).
 SContext context -> GColumns PGTable context -> PGTable context)
-> (forall (context :: Context).
    SContext context -> PGTable context -> GColumns PGTable context)
-> (GColumns PGTable Result -> GFromExprs PGTable)
-> (GFromExprs PGTable -> GColumns PGTable Result)
-> Rel8able PGTable
GColumns PGTable Result -> GFromExprs PGTable
GFromExprs PGTable -> GColumns PGTable Result
forall (context :: Context).
SContext context -> GColumns PGTable context -> PGTable context
forall (context :: Context).
SContext context -> PGTable context -> GColumns PGTable context
forall (t :: HTable).
HTable (GColumns t) =>
(forall (context :: Context).
 SContext context -> GColumns t context -> t context)
-> (forall (context :: Context).
    SContext context -> t context -> GColumns t context)
-> (GColumns t Result -> GFromExprs t)
-> (GFromExprs t -> GColumns t Result)
-> Rel8able t
$cgfromColumns :: forall (context :: Context).
SContext context -> GColumns PGTable context -> PGTable context
gfromColumns :: forall (context :: Context).
SContext context -> GColumns PGTable context -> PGTable context
$cgtoColumns :: forall (context :: Context).
SContext context -> PGTable context -> GColumns PGTable context
gtoColumns :: forall (context :: Context).
SContext context -> PGTable context -> GColumns PGTable context
$cgfromResult :: GColumns PGTable Result -> GFromExprs PGTable
gfromResult :: GColumns PGTable Result -> GFromExprs PGTable
$cgtoResult :: GFromExprs PGTable -> GColumns PGTable Result
gtoResult :: GFromExprs PGTable -> GColumns PGTable Result
Rel8able)

deriving stock instance Show (PGTable Result)

data Attribute f = Attribute
  { forall (f :: Context). Attribute f -> PGAttribute f
attribute :: PGAttribute f
  , forall (f :: Context). Attribute f -> PGType f
typ :: PGType f
  , forall (f :: Context). Attribute f -> PGNamespace f
namespace :: PGNamespace f
  }
  deriving stock ((forall x. Attribute f -> Rep (Attribute f) x)
-> (forall x. Rep (Attribute f) x -> Attribute f)
-> Generic (Attribute f)
forall x. Rep (Attribute f) x -> Attribute f
forall x. Attribute f -> Rep (Attribute f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: Context) x. Rep (Attribute f) x -> Attribute f
forall (f :: Context) x. Attribute f -> Rep (Attribute f) x
$cfrom :: forall (f :: Context) x. Attribute f -> Rep (Attribute f) x
from :: forall x. Attribute f -> Rep (Attribute f) x
$cto :: forall (f :: Context) x. Rep (Attribute f) x -> Attribute f
to :: forall x. Rep (Attribute f) x -> Attribute f
Generic)
  deriving anyclass (HTable (GColumns Attribute)
HTable (GColumns Attribute) =>
(forall (context :: Context).
 SContext context
 -> GColumns Attribute context -> Attribute context)
-> (forall (context :: Context).
    SContext context
    -> Attribute context -> GColumns Attribute context)
-> (GColumns Attribute Result -> GFromExprs Attribute)
-> (GFromExprs Attribute -> GColumns Attribute Result)
-> Rel8able Attribute
GColumns Attribute Result -> GFromExprs Attribute
GFromExprs Attribute -> GColumns Attribute Result
forall (context :: Context).
SContext context -> GColumns Attribute context -> Attribute context
forall (context :: Context).
SContext context -> Attribute context -> GColumns Attribute context
forall (t :: HTable).
HTable (GColumns t) =>
(forall (context :: Context).
 SContext context -> GColumns t context -> t context)
-> (forall (context :: Context).
    SContext context -> t context -> GColumns t context)
-> (GColumns t Result -> GFromExprs t)
-> (GFromExprs t -> GColumns t Result)
-> Rel8able t
$cgfromColumns :: forall (context :: Context).
SContext context -> GColumns Attribute context -> Attribute context
gfromColumns :: forall (context :: Context).
SContext context -> GColumns Attribute context -> Attribute context
$cgtoColumns :: forall (context :: Context).
SContext context -> Attribute context -> GColumns Attribute context
gtoColumns :: forall (context :: Context).
SContext context -> Attribute context -> GColumns Attribute context
$cgfromResult :: GColumns Attribute Result -> GFromExprs Attribute
gfromResult :: GColumns Attribute Result -> GFromExprs Attribute
$cgtoResult :: GFromExprs Attribute -> GColumns Attribute Result
gtoResult :: GFromExprs Attribute -> GColumns Attribute Result
Rel8able)

deriving stock instance Show (Attribute Result)

data Cast f = Cast
  { forall (f :: Context). Cast f -> PGType f
source :: PGType f
  , forall (f :: Context). Cast f -> PGType f
target :: PGType f
  , forall (f :: Context). Cast f -> Column f Text
context :: Column f Text -- Char 
  }
  deriving stock ((forall x. Cast f -> Rep (Cast f) x)
-> (forall x. Rep (Cast f) x -> Cast f) -> Generic (Cast f)
forall x. Rep (Cast f) x -> Cast f
forall x. Cast f -> Rep (Cast f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: Context) x. Rep (Cast f) x -> Cast f
forall (f :: Context) x. Cast f -> Rep (Cast f) x
$cfrom :: forall (f :: Context) x. Cast f -> Rep (Cast f) x
from :: forall x. Cast f -> Rep (Cast f) x
$cto :: forall (f :: Context) x. Rep (Cast f) x -> Cast f
to :: forall x. Rep (Cast f) x -> Cast f
Generic)
  deriving anyclass (HTable (GColumns Cast)
HTable (GColumns Cast) =>
(forall (context :: Context).
 SContext context -> GColumns Cast context -> Cast context)
-> (forall (context :: Context).
    SContext context -> Cast context -> GColumns Cast context)
-> (GColumns Cast Result -> GFromExprs Cast)
-> (GFromExprs Cast -> GColumns Cast Result)
-> Rel8able Cast
GColumns Cast Result -> GFromExprs Cast
GFromExprs Cast -> GColumns Cast Result
forall (context :: Context).
SContext context -> GColumns Cast context -> Cast context
forall (context :: Context).
SContext context -> Cast context -> GColumns Cast context
forall (t :: HTable).
HTable (GColumns t) =>
(forall (context :: Context).
 SContext context -> GColumns t context -> t context)
-> (forall (context :: Context).
    SContext context -> t context -> GColumns t context)
-> (GColumns t Result -> GFromExprs t)
-> (GFromExprs t -> GColumns t Result)
-> Rel8able t
$cgfromColumns :: forall (context :: Context).
SContext context -> GColumns Cast context -> Cast context
gfromColumns :: forall (context :: Context).
SContext context -> GColumns Cast context -> Cast context
$cgtoColumns :: forall (context :: Context).
SContext context -> Cast context -> GColumns Cast context
gtoColumns :: forall (context :: Context).
SContext context -> Cast context -> GColumns Cast context
$cgfromResult :: GColumns Cast Result -> GFromExprs Cast
gfromResult :: GColumns Cast Result -> GFromExprs Cast
$cgtoResult :: GFromExprs Cast -> GColumns Cast Result
gtoResult :: GFromExprs Cast -> GColumns Cast Result
Rel8able)

deriving stock instance Show (Cast Result)

fetchTables :: Query (ListTable Expr (PGTable Expr))
fetchTables :: Query (ListTable Expr (PGTable Expr))
fetchTables = Query (PGTable Expr) -> Query (ListTable Expr (PGTable Expr))
forall a. Table Expr a => Query a -> Query (ListTable Expr a)
many do
    PGClass{ oid :: forall (f :: Context). PGClass f -> Column f Oid
oid = Column Expr Oid
tableOid, Column Expr Text
relname :: forall (f :: Context). PGClass f -> Column f Text
relname :: Column Expr Text
relname } <- Order (PGClass Expr)
-> Query (PGClass Expr) -> Query (PGClass Expr)
forall a. Order a -> Query a -> Query a
orderBy (PGClass Expr -> Column Expr Text
PGClass Expr -> Expr Text
forall (f :: Context). PGClass f -> Column f Text
relname (PGClass Expr -> Expr Text)
-> Order (Expr Text) -> Order (PGClass Expr)
forall (f :: Context) a b.
Contravariant f =>
(a -> b) -> f b -> f a
>$< Order (Expr Text)
forall a. DBOrd a => Order (Expr a)
asc) do
      TableSchema (PGClass Name) -> Query (PGClass Expr)
forall names exprs.
Selects names exprs =>
TableSchema names -> Query exprs
each TableSchema (PGClass Name)
pgclass
        Query (PGClass Expr)
-> (PGClass Expr -> Query (PGClass Expr)) -> Query (PGClass Expr)
forall a b. Query a -> (a -> Query b) -> Query b
forall (m :: Context) a b. Monad m => m a -> (a -> m b) -> m b
>>= (PGClass Expr -> Expr Bool) -> PGClass Expr -> Query (PGClass Expr)
forall a. (a -> Expr Bool) -> a -> Query a
filter ((Relkind -> Expr Relkind
forall exprs a. Serializable exprs a => a -> exprs
lit Relkind
OrdinaryTable Expr Relkind -> Expr Relkind -> Expr Bool
forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
==.) (Expr Relkind -> Expr Bool)
-> (PGClass Expr -> Expr Relkind) -> PGClass Expr -> Expr Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGClass Expr -> Column Expr Relkind
PGClass Expr -> Expr Relkind
forall (f :: Context). PGClass f -> Column f Relkind
relkind)

    ListTable Expr (Attribute Expr)
columns <- Query (Attribute Expr) -> Query (ListTable Expr (Attribute Expr))
forall a. Table Expr a => Query a -> Query (ListTable Expr a)
many do
      attribute :: PGAttribute Expr
attribute@PGAttribute{ Column Expr Oid
atttypid :: forall (f :: Context). PGAttribute f -> Column f Oid
atttypid :: Column Expr Oid
atttypid } <-
        TableSchema (PGAttribute Name) -> Query (PGAttribute Expr)
forall names exprs.
Selects names exprs =>
TableSchema names -> Query exprs
each TableSchema (PGAttribute Name)
pgattribute
          Query (PGAttribute Expr)
-> (PGAttribute Expr -> Query (PGAttribute Expr))
-> Query (PGAttribute Expr)
forall a b. Query a -> (a -> Query b) -> Query b
forall (m :: Context) a b. Monad m => m a -> (a -> m b) -> m b
>>= (PGAttribute Expr -> Expr Bool)
-> PGAttribute Expr -> Query (PGAttribute Expr)
forall a. (a -> Expr Bool) -> a -> Query a
filter ((Column Expr Oid
Expr Oid
tableOid Expr Oid -> Expr Oid -> Expr Bool
forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
==.) (Expr Oid -> Expr Bool)
-> (PGAttribute Expr -> Expr Oid) -> PGAttribute Expr -> Expr Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGAttribute Expr -> Column Expr Oid
PGAttribute Expr -> Expr Oid
forall (f :: Context). PGAttribute f -> Column f Oid
attrelid)
          Query (PGAttribute Expr)
-> (PGAttribute Expr -> Query (PGAttribute Expr))
-> Query (PGAttribute Expr)
forall a b. Query a -> (a -> Query b) -> Query b
forall (m :: Context) a b. Monad m => m a -> (a -> m b) -> m b
>>= (PGAttribute Expr -> Expr Bool)
-> PGAttribute Expr -> Query (PGAttribute Expr)
forall a. (a -> Expr Bool) -> a -> Query a
filter ((Expr Int64 -> Expr Int64 -> Expr Bool
forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
>. Expr Int64
0) (Expr Int64 -> Expr Bool)
-> (PGAttribute Expr -> Expr Int64)
-> PGAttribute Expr
-> Expr Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGAttribute Expr -> Column Expr Int64
PGAttribute Expr -> Expr Int64
forall (f :: Context). PGAttribute f -> Column f Int64
attnum)

      PGType Expr
typ <-
        TableSchema (PGType Name) -> Query (PGType Expr)
forall names exprs.
Selects names exprs =>
TableSchema names -> Query exprs
each TableSchema (PGType Name)
pgtype
          Query (PGType Expr)
-> (PGType Expr -> Query (PGType Expr)) -> Query (PGType Expr)
forall a b. Query a -> (a -> Query b) -> Query b
forall (m :: Context) a b. Monad m => m a -> (a -> m b) -> m b
>>= (PGType Expr -> Expr Bool) -> PGType Expr -> Query (PGType Expr)
forall a. (a -> Expr Bool) -> a -> Query a
filter (\PGType{ oid :: forall (f :: Context). PGType f -> Column f Oid
oid = Column Expr Oid
typoid } -> Column Expr Oid
Expr Oid
atttypid Expr Oid -> Expr Oid -> Expr Bool
forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
==. Column Expr Oid
Expr Oid
typoid)

      PGNamespace Expr
namespace <-
        TableSchema (PGNamespace Name) -> Query (PGNamespace Expr)
forall names exprs.
Selects names exprs =>
TableSchema names -> Query exprs
each TableSchema (PGNamespace Name)
pgnamespace
          Query (PGNamespace Expr)
-> (PGNamespace Expr -> Query (PGNamespace Expr))
-> Query (PGNamespace Expr)
forall a b. Query a -> (a -> Query b) -> Query b
forall (m :: Context) a b. Monad m => m a -> (a -> m b) -> m b
>>= (PGNamespace Expr -> Expr Bool)
-> PGNamespace Expr -> Query (PGNamespace Expr)
forall a. (a -> Expr Bool) -> a -> Query a
filter (\PGNamespace{ oid :: forall (f :: Context). PGNamespace f -> Column f Oid
oid = Column Expr Oid
nsoid } -> Column Expr Oid
Expr Oid
nsoid Expr Oid -> Expr Oid -> Expr Bool
forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
==. PGType Expr
typ.typnamespace)



      Attribute Expr -> Query (Attribute Expr)
forall a. a -> Query a
forall (m :: Context) a. Monad m => a -> m a
return Attribute{ PGAttribute Expr
attribute :: PGAttribute Expr
attribute :: PGAttribute Expr
attribute, PGType Expr
typ :: PGType Expr
typ :: PGType Expr
typ, PGNamespace Expr
namespace :: PGNamespace Expr
namespace :: PGNamespace Expr
namespace }

    PGTable Expr -> Query (PGTable Expr)
forall a. a -> Query a
forall (m :: Context) a. Monad m => a -> m a
return PGTable
      { name :: Column Expr Text
name = Column Expr Text
relname
      , ListTable Expr (Attribute Expr)
HList Expr (Attribute Expr)
columns :: HList Expr (Attribute Expr)
columns :: ListTable Expr (Attribute Expr)
..
      }

fetchCasts :: Query (ListTable Expr (Cast Expr))
fetchCasts :: Query (ListTable Expr (Cast Expr))
fetchCasts = Query (Cast Expr) -> Query (ListTable Expr (Cast Expr))
forall a. Table Expr a => Query a -> Query (ListTable Expr a)
many do
    PGCast {Column Expr Oid
castsource :: forall (f :: Context). PGCast f -> Column f Oid
castsource :: Column Expr Oid
castsource, Column Expr Oid
casttarget :: forall (f :: Context). PGCast f -> Column f Oid
casttarget :: Column Expr Oid
casttarget, Column Expr Text
castcontext :: forall (f :: Context). PGCast f -> Column f Text
castcontext :: Column Expr Text
castcontext} <- TableSchema (PGCast Name) -> Query (PGCast Expr)
forall names exprs.
Selects names exprs =>
TableSchema names -> Query exprs
each TableSchema (PGCast Name)
pgcast
    PGType Expr
src <- TableSchema (PGType Name) -> Query (PGType Expr)
forall names exprs.
Selects names exprs =>
TableSchema names -> Query exprs
each TableSchema (PGType Name)
pgtype Query (PGType Expr)
-> (PGType Expr -> Query (PGType Expr)) -> Query (PGType Expr)
forall a b. Query a -> (a -> Query b) -> Query b
forall (m :: Context) a b. Monad m => m a -> (a -> m b) -> m b
>>= (PGType Expr -> Expr Bool) -> PGType Expr -> Query (PGType Expr)
forall a. (a -> Expr Bool) -> a -> Query a
filter (\PGType { oid :: forall (f :: Context). PGType f -> Column f Oid
oid = Column Expr Oid
typoid } -> Column Expr Oid
Expr Oid
typoid Expr Oid -> Expr Oid -> Expr Bool
forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
==. Column Expr Oid
Expr Oid
castsource)
    PGType Expr
tgt <- TableSchema (PGType Name) -> Query (PGType Expr)
forall names exprs.
Selects names exprs =>
TableSchema names -> Query exprs
each TableSchema (PGType Name)
pgtype Query (PGType Expr)
-> (PGType Expr -> Query (PGType Expr)) -> Query (PGType Expr)
forall a b. Query a -> (a -> Query b) -> Query b
forall (m :: Context) a b. Monad m => m a -> (a -> m b) -> m b
>>= (PGType Expr -> Expr Bool) -> PGType Expr -> Query (PGType Expr)
forall a. (a -> Expr Bool) -> a -> Query a
filter (\PGType { oid :: forall (f :: Context). PGType f -> Column f Oid
oid = Column Expr Oid
typoid } -> Column Expr Oid
Expr Oid
typoid Expr Oid -> Expr Oid -> Expr Bool
forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
==. Column Expr Oid
Expr Oid
casttarget)
    Cast Expr -> Query (Cast Expr)
forall a. a -> Query a
forall (m :: Context) a. Monad m => a -> m a
return Cast { source :: PGType Expr
source = PGType Expr
src, target :: PGType Expr
target = PGType Expr
tgt, context :: Column Expr Text
context = Column Expr Text
castcontext }


data CheckEnv = CheckEnv
  { CheckEnv -> Map String [Attribute Result]
schemaMap :: M.Map String [Attribute Result] -- map of schemas to attributes
  , CheckEnv -> [(String, String)]
casts :: [(String, String)] -- list of implicit casts
  } deriving (Int -> CheckEnv -> ShowS
[CheckEnv] -> ShowS
CheckEnv -> String
(Int -> CheckEnv -> ShowS)
-> (CheckEnv -> String) -> ([CheckEnv] -> ShowS) -> Show CheckEnv
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CheckEnv -> ShowS
showsPrec :: Int -> CheckEnv -> ShowS
$cshow :: CheckEnv -> String
show :: CheckEnv -> String
$cshowList :: [CheckEnv] -> ShowS
showList :: [CheckEnv] -> ShowS
Show)


nullableToBool :: Nullity a -> Bool
nullableToBool :: forall a. Nullity a -> Bool
nullableToBool Nullity a
Null = Bool
True
nullableToBool Nullity a
NotNull = Bool
False


attrsToMap :: [Attribute Result] -> M.Map String (Attribute Result)
attrsToMap :: [Attribute Result] -> Map String (Attribute Result)
attrsToMap = [(String, Attribute Result)] -> Map String (Attribute Result)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, Attribute Result)] -> Map String (Attribute Result))
-> ([Attribute Result] -> [(String, Attribute Result)])
-> [Attribute Result]
-> Map String (Attribute Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attribute Result -> (String, Attribute Result))
-> [Attribute Result] -> [(String, Attribute Result)]
forall a b. (a -> b) -> [a] -> [b]
map (\Attribute Result
attr -> (Text -> String
T.unpack Attribute Result
attr.attribute.attname, Attribute Result
attr))


data TypeInfo = TypeInfo
  { TypeInfo -> [String]
label :: [String]
  , TypeInfo -> Bool
isNull :: Bool
  , TypeInfo -> TypeName
typeName :: TypeName
  }
instance Show TypeInfo where
  show :: TypeInfo -> String
show = TypeInfo -> String
showTypeInfo


-- @'schemaToTypeMap'@ takes a schema and returns a map of database column names
-- to the type information associated with the column. It is possible (though
-- undesirable) to write a schema which has multiple columns with the same name,
-- so a list of results are returned for each key.
schemaToTypeMap :: forall k. Rel8able k => k Name -> M.Map String (NonEmpty.NonEmpty TypeInfo)
schemaToTypeMap :: forall (k :: HTable).
Rel8able k =>
k Name -> Map String (NonEmpty TypeInfo)
schemaToTypeMap k Name
cols = [(String, TypeInfo)] -> Map String (NonEmpty TypeInfo)
go ([(String, TypeInfo)] -> Map String (NonEmpty TypeInfo))
-> (Const ([String], [TypeInfo]) (GColumns k Any)
    -> [(String, TypeInfo)])
-> Const ([String], [TypeInfo]) (GColumns k Any)
-> Map String (NonEmpty TypeInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> [TypeInfo] -> [(String, TypeInfo)])
-> ([String], [TypeInfo]) -> [(String, TypeInfo)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [String] -> [TypeInfo] -> [(String, TypeInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip (([String], [TypeInfo]) -> [(String, TypeInfo)])
-> (Const ([String], [TypeInfo]) (GColumns k Any)
    -> ([String], [TypeInfo]))
-> Const ([String], [TypeInfo]) (GColumns k Any)
-> [(String, TypeInfo)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const ([String], [TypeInfo]) (GColumns k Any)
-> ([String], [TypeInfo])
forall {k} a (b :: k). Const a b -> a
getConst (Const ([String], [TypeInfo]) (GColumns k Any)
 -> Map String (NonEmpty TypeInfo))
-> Const ([String], [TypeInfo]) (GColumns k Any)
-> Map String (NonEmpty TypeInfo)
forall a b. (a -> b) -> a -> b
$
  forall (t :: HTable) (m :: Context) (context :: Context).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA @(Columns (k Name)) ((forall a.
  HField (Columns (k Name)) a
  -> Const ([String], [TypeInfo]) (Any a))
 -> Const ([String], [TypeInfo]) (Columns (k Name) Any))
-> (forall a.
    HField (Columns (k Name)) a
    -> Const ([String], [TypeInfo]) (Any a))
-> Const ([String], [TypeInfo]) (Columns (k Name) Any)
forall a b. (a -> b) -> a -> b
$ \HField (Columns (k Name)) a
field -> 
    case (GColumns k Spec -> HField (GColumns k) a -> Spec a
forall (context :: Context) a.
GColumns k context -> HField (GColumns k) a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield GColumns k Spec
forall (t :: HTable). HTable t => t Spec
hspecs HField (Columns (k Name)) a
HField (GColumns k) a
field, GColumns k Name -> HField (GColumns k) a -> Name a
forall (context :: Context) a.
GColumns k context -> HField (GColumns k) a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield (k Name -> Columns (k Name) Name
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns k Name
cols) HField (Columns (k Name)) a
HField (GColumns k) a
field) of 
      (Spec {[String]
Nullity a
TypeInformation (Unnullify' (IsMaybe a) a)
labels :: [String]
info :: TypeInformation (Unnullify' (IsMaybe a) a)
nullity :: Nullity a
nullity :: forall a. Spec a -> Nullity a
info :: forall a. Spec a -> TypeInformation (Unnullify a)
labels :: forall a. Spec a -> [String]
..}, Name String
name) -> ([String], [TypeInfo]) -> Const ([String], [TypeInfo]) (Any a)
forall {k} a (b :: k). a -> Const a b
Const ([String
name], [
        TypeInfo { label :: [String]
label = [String]
labels
                 , isNull :: Bool
isNull = Nullity a -> Bool
forall a. Nullity a -> Bool
nullableToBool Nullity a
nullity
                 , typeName :: TypeName
typeName = TypeInformation (Unnullify' (IsMaybe a) a)
info.typeName}])
  where
    go :: [(String, TypeInfo)] -> M.Map String (NonEmpty.NonEmpty TypeInfo)
    go :: [(String, TypeInfo)] -> Map String (NonEmpty TypeInfo)
go = (NonEmpty TypeInfo -> NonEmpty TypeInfo -> NonEmpty TypeInfo)
-> [(String, NonEmpty TypeInfo)] -> Map String (NonEmpty TypeInfo)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith NonEmpty TypeInfo -> NonEmpty TypeInfo -> NonEmpty TypeInfo
forall a. Semigroup a => a -> a -> a
(<>) ([(String, NonEmpty TypeInfo)] -> Map String (NonEmpty TypeInfo))
-> ([(String, TypeInfo)] -> [(String, NonEmpty TypeInfo)])
-> [(String, TypeInfo)]
-> Map String (NonEmpty TypeInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, TypeInfo) -> (String, NonEmpty TypeInfo))
-> [(String, TypeInfo)] -> [(String, NonEmpty TypeInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
name, TypeInfo
typeInfo) -> (String
name, TypeInfo -> NonEmpty TypeInfo
forall a. a -> NonEmpty a
NonEmpty.singleton TypeInfo
typeInfo))

-- A checked version of @schemaToTypeMap@, which returns a list of columns with
-- duplicate names if any such columns are present. Otherwise it returns the
-- type map with no duplicates.
checkedSchemaToTypeMap :: Rel8able k
  => k Name
  -> Either (M.Map String (NonEmpty.NonEmpty TypeInfo)) (M.Map String TypeInfo)
checkedSchemaToTypeMap :: forall (k :: HTable).
Rel8able k =>
k Name
-> Either (Map String (NonEmpty TypeInfo)) (Map String TypeInfo)
checkedSchemaToTypeMap k Name
cols =
  let typeMap :: Map String (NonEmpty TypeInfo)
typeMap = k Name -> Map String (NonEmpty TypeInfo)
forall (k :: HTable).
Rel8able k =>
k Name -> Map String (NonEmpty TypeInfo)
schemaToTypeMap k Name
cols
      duplicates :: Map String (NonEmpty TypeInfo)
duplicates = (NonEmpty TypeInfo -> Bool)
-> Map String (NonEmpty TypeInfo) -> Map String (NonEmpty TypeInfo)
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (\NonEmpty TypeInfo
col -> NonEmpty TypeInfo -> Int
forall a. NonEmpty a -> Int
forall (t :: Context) a. Foldable t => t a -> Int
length NonEmpty TypeInfo
col Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) Map String (NonEmpty TypeInfo)
typeMap
  in if Map String (NonEmpty TypeInfo) -> Int
forall a. Map String a -> Int
forall (t :: Context) a. Foldable t => t a -> Int
length Map String (NonEmpty TypeInfo)
duplicates Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
  then Map String (NonEmpty TypeInfo)
-> Either (Map String (NonEmpty TypeInfo)) (Map String TypeInfo)
forall a b. a -> Either a b
Left Map String (NonEmpty TypeInfo)
duplicates
  else Map String TypeInfo
-> Either (Map String (NonEmpty TypeInfo)) (Map String TypeInfo)
forall a b. b -> Either a b
Right (Map String (NonEmpty TypeInfo)
typeMap Map String (NonEmpty TypeInfo)
-> (Map String (NonEmpty TypeInfo) -> Map String TypeInfo)
-> Map String TypeInfo
forall a b. a -> (a -> b) -> b
& (NonEmpty TypeInfo -> Maybe TypeInfo)
-> Map String (NonEmpty TypeInfo) -> Map String TypeInfo
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
M.mapMaybe \case
    TypeInfo
a :| [] -> TypeInfo -> Maybe TypeInfo
forall a. a -> Maybe a
Just TypeInfo
a
    NonEmpty TypeInfo
_ -> Maybe TypeInfo
forall a. Maybe a
Nothing)


showCreateTable_helper :: String -> M.Map String TypeInfo -> String
showCreateTable_helper :: String -> Map String TypeInfo -> String
showCreateTable_helper String
name Map String TypeInfo
typeMap = String
"CREATE TABLE " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> String
show String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" ("
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
"," (((String, TypeInfo) -> String) -> [(String, TypeInfo)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, TypeInfo) -> String
go ([(String, TypeInfo)] -> [String])
-> [(String, TypeInfo)] -> [String]
forall a b. (a -> b) -> a -> b
$ Map String TypeInfo -> [(String, TypeInfo)]
forall k a. Map k a -> [(k, a)]
M.assocs Map String TypeInfo
typeMap)
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n);"
  where
    go :: (String, TypeInfo) -> String
    go :: (String, TypeInfo) -> String
go (String
name, TypeInfo
typeInfo) = String
"\n    " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeInfo -> String
showTypeInfo TypeInfo
typeInfo


-- |@'showCreateTable'@ shows an example CREATE TABLE statement for the table.
-- This does not show relationships like primary or foreign keys, but can still
-- be useful to see what types @rel8@ will expect of the underlying database.
--
-- In the event that multiple columns have the same name, this will fail silently. To
-- handle that case, see 'checkedShowCreateTable'
showCreateTable :: Rel8able k => TableSchema (k Name) -> String
showCreateTable :: forall (k :: HTable). Rel8able k => TableSchema (k Name) -> String
showCreateTable TableSchema (k Name)
schema = String -> Map String TypeInfo -> String
showCreateTable_helper TableSchema (k Name)
schema.name.name (Map String TypeInfo -> String) -> Map String TypeInfo -> String
forall a b. (a -> b) -> a -> b
$ (NonEmpty TypeInfo -> TypeInfo)
-> Map String (NonEmpty TypeInfo) -> Map String TypeInfo
forall a b. (a -> b) -> Map String a -> Map String b
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty TypeInfo -> TypeInfo
forall a. NonEmpty a -> a
NonEmpty.head (Map String (NonEmpty TypeInfo) -> Map String TypeInfo)
-> Map String (NonEmpty TypeInfo) -> Map String TypeInfo
forall a b. (a -> b) -> a -> b
$ k Name -> Map String (NonEmpty TypeInfo)
forall (k :: HTable).
Rel8able k =>
k Name -> Map String (NonEmpty TypeInfo)
schemaToTypeMap TableSchema (k Name)
schema.columns

-- |@'checkedShowCreateTable'@ shows an example CREATE TABLE statement for the
-- table. This does not show relationships like primary or foreign keys, but can
-- still be useful to see what types rel8 will expect of the underlying database.
--
-- In the event that multiple columns have the same name, this will return a map of
-- names to the labels identifying the column.
checkedShowCreateTable :: Rel8able k => TableSchema (k Name) -> Either (M.Map String (NonEmpty [String])) String
checkedShowCreateTable :: forall (k :: HTable).
Rel8able k =>
TableSchema (k Name)
-> Either (Map String (NonEmpty [String])) String
checkedShowCreateTable TableSchema (k Name)
schema = case k Name
-> Either (Map String (NonEmpty TypeInfo)) (Map String TypeInfo)
forall (k :: HTable).
Rel8able k =>
k Name
-> Either (Map String (NonEmpty TypeInfo)) (Map String TypeInfo)
checkedSchemaToTypeMap TableSchema (k Name)
schema.columns of
    Left Map String (NonEmpty TypeInfo)
e -> Map String (NonEmpty [String])
-> Either (Map String (NonEmpty [String])) String
forall a b. a -> Either a b
Left (Map String (NonEmpty [String])
 -> Either (Map String (NonEmpty [String])) String)
-> Map String (NonEmpty [String])
-> Either (Map String (NonEmpty [String])) String
forall a b. (a -> b) -> a -> b
$ ((NonEmpty TypeInfo -> NonEmpty [String])
-> Map String (NonEmpty TypeInfo) -> Map String (NonEmpty [String])
forall a b. (a -> b) -> Map String a -> Map String b
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NonEmpty TypeInfo -> NonEmpty [String])
 -> Map String (NonEmpty TypeInfo)
 -> Map String (NonEmpty [String]))
-> ((TypeInfo -> [String])
    -> NonEmpty TypeInfo -> NonEmpty [String])
-> (TypeInfo -> [String])
-> Map String (NonEmpty TypeInfo)
-> Map String (NonEmpty [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeInfo -> [String]) -> NonEmpty TypeInfo -> NonEmpty [String]
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
fmap) (\TypeInfo
typ -> TypeInfo
typ.label)  Map String (NonEmpty TypeInfo)
e
    Right Map String TypeInfo
a -> String -> Either (Map String (NonEmpty [String])) String
forall a b. b -> Either a b
Right (String -> Either (Map String (NonEmpty [String])) String)
-> String -> Either (Map String (NonEmpty [String])) String
forall a b. (a -> b) -> a -> b
$ String -> Map String TypeInfo -> String
showCreateTable_helper TableSchema (k Name)
schema.name.name Map String TypeInfo
a

-- implicit casts are ok as long as they're bidirectional
checkTypeEquality :: CheckEnv -> TypeInfo -> TypeInfo -> Maybe ColumnError
checkTypeEquality :: CheckEnv -> TypeInfo -> TypeInfo -> Maybe ColumnError
checkTypeEquality CheckEnv
env TypeInfo
db TypeInfo
hs
  | [Bool] -> Bool
forall (t :: Context). Foldable t => t Bool -> Bool
Prelude.and [Bool
sameDims, Bool
sameMods, TypeInfo -> String
toName TypeInfo
db String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== TypeInfo -> String
toName TypeInfo
hs Bool -> Bool -> Bool
|| Bool
castExists]
    = Maybe ColumnError
forall a. Maybe a
Nothing
  | Bool
otherwise
    = ColumnError -> Maybe ColumnError
forall a. a -> Maybe a
Just ColumnError
BidirectionalCastDoesNotExist
  where
    castExists :: Bool
castExists = [Bool] -> Bool
forall (t :: Context). Foldable t => t Bool -> Bool
Prelude.and
      [ (TypeInfo -> String
toName TypeInfo
db, TypeInfo -> String
toName TypeInfo
hs) (String, String) -> [(String, String)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Context) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CheckEnv
env.casts
      , (TypeInfo -> String
toName TypeInfo
hs, TypeInfo -> String
toName TypeInfo
db) (String, String) -> [(String, String)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Context) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CheckEnv
env.casts
      ]

    sameMods, sameDims :: Bool
    sameMods :: Bool
sameMods = TypeInfo
db.typeName.modifiers [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
== TypeInfo
hs.typeName.modifiers
    sameDims :: Bool
sameDims = TypeInfo
db.typeName.arrayDepth Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== TypeInfo
hs.typeName.arrayDepth

    sameName :: Bool
sameName = QualifiedName -> QualifiedName -> Bool
equalName TypeInfo
db.typeName.name TypeInfo
hs.typeName.name

    toName :: TypeInfo -> String
    toName :: TypeInfo -> String
toName TypeInfo
typeInfo = case TypeInfo
typeInfo.typeName.name of
        QualifiedName String
name Maybe String
_ -> (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
L.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'_') String
name

equalName :: QualifiedName -> QualifiedName -> Bool
equalName :: QualifiedName -> QualifiedName -> Bool
equalName (QualifiedName String
a (Just String
b)) (QualifiedName String
a' (Just String
b'))
  = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
L.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'_') String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
L.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'_') String
a' Bool -> Bool -> Bool
&& String
b String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
b'
equalName (QualifiedName String
a Maybe String
_) (QualifiedName String
a' Maybe String
_)
  = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'_') String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'_') String
a'

-- check types for a single table
compareTypes
    :: CheckEnv
    -> M.Map String (Attribute Result)
    -> M.Map String TypeInfo
    -> [ColumnInfo]
compareTypes :: CheckEnv
-> Map String (Attribute Result)
-> Map String TypeInfo
-> [ColumnInfo]
compareTypes CheckEnv
env Map String (Attribute Result)
attrMap Map String TypeInfo
typeMap = ((String, These (Attribute Result) TypeInfo) -> ColumnInfo)
-> [(String, These (Attribute Result) TypeInfo)] -> [ColumnInfo]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> These (Attribute Result) TypeInfo -> ColumnInfo)
-> (String, These (Attribute Result) TypeInfo) -> ColumnInfo
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> These (Attribute Result) TypeInfo -> ColumnInfo
go) ([(String, These (Attribute Result) TypeInfo)] -> [ColumnInfo])
-> [(String, These (Attribute Result) TypeInfo)] -> [ColumnInfo]
forall a b. (a -> b) -> a -> b
$ Map String (These (Attribute Result) TypeInfo)
-> [(String, These (Attribute Result) TypeInfo)]
forall k a. Map k a -> [(k, a)]
M.assocs (Map String (Attribute Result)
-> Map String TypeInfo
-> Map String (These (Attribute Result) TypeInfo)
forall k a b. Ord k => Map k a -> Map k b -> Map k (These a b)
disjointUnion Map String (Attribute Result)
attrMap Map String TypeInfo
typeMap)
  where
    go :: String -> These (Attribute Result) TypeInfo -> ColumnInfo
    go :: String -> These (Attribute Result) TypeInfo -> ColumnInfo
go String
name (These Attribute Result
a TypeInfo
b) = ColumnInfo
        { name :: String
name = String
name
        , dbType :: Maybe TypeInfo
dbType = TypeInfo -> Maybe TypeInfo
forall a. a -> Maybe a
Just (TypeInfo -> Maybe TypeInfo) -> TypeInfo -> Maybe TypeInfo
forall a b. (a -> b) -> a -> b
$ Attribute Result -> TypeInfo
fromAttribute Attribute Result
a
        , hsType :: Maybe TypeInfo
hsType = TypeInfo -> Maybe TypeInfo
forall a. a -> Maybe a
Just (TypeInfo -> Maybe TypeInfo) -> TypeInfo -> Maybe TypeInfo
forall a b. (a -> b) -> a -> b
$ TypeInfo
b
        , error :: Maybe ColumnError
error = CheckEnv -> TypeInfo -> TypeInfo -> Maybe ColumnError
checkTypeEquality CheckEnv
env (Attribute Result -> TypeInfo
fromAttribute Attribute Result
a) TypeInfo
b
        }
    go String
name (This Attribute Result
a) = ColumnInfo
        { name :: String
name = String
name
        , dbType :: Maybe TypeInfo
dbType = TypeInfo -> Maybe TypeInfo
forall a. a -> Maybe a
Just (TypeInfo -> Maybe TypeInfo) -> TypeInfo -> Maybe TypeInfo
forall a b. (a -> b) -> a -> b
$ Attribute Result -> TypeInfo
fromAttribute Attribute Result
a
        , hsType :: Maybe TypeInfo
hsType = Maybe TypeInfo
forall a. Maybe a
Nothing
        , error :: Maybe ColumnError
error =
            if Attribute Result
a.attribute.attnotnull
            then ColumnError -> Maybe ColumnError
forall a. a -> Maybe a
Just ColumnError
DbTypeIsNotNullButNotPresentInHsType
            else Maybe ColumnError
forall a. Maybe a
Nothing
        }
    go String
name (That TypeInfo
b) = ColumnInfo
        { name :: String
name = String
name
        , dbType :: Maybe TypeInfo
dbType = Maybe TypeInfo
forall a. Maybe a
Nothing
        , hsType :: Maybe TypeInfo
hsType = TypeInfo -> Maybe TypeInfo
forall a. a -> Maybe a
Just (TypeInfo -> Maybe TypeInfo) -> TypeInfo -> Maybe TypeInfo
forall a b. (a -> b) -> a -> b
$ TypeInfo
b
        , error :: Maybe ColumnError
error = ColumnError -> Maybe ColumnError
forall a. a -> Maybe a
Just ColumnError
HsTypeIsPresentButNotPresentInDbType
        }

    fromAttribute :: Attribute Result -> TypeInfo
    fromAttribute :: Attribute Result -> TypeInfo
fromAttribute Attribute Result
attr = TypeInfo
        { label :: [String]
label = [Text -> String
T.unpack Attribute Result
attr.attribute.attname]
        , isNull :: Bool
isNull = Bool -> Bool
not Attribute Result
attr.attribute.attnotnull
        , typeName :: TypeName
typeName = TypeName
            { name :: QualifiedName
name = String -> Maybe String -> QualifiedName
QualifiedName
                (Text -> String
T.unpack Attribute Result
attr.typ.typname)
                (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Attribute Result
attr.namespace.nspname)
            , modifiers :: [String]
modifiers = Text -> Int64 -> [String]
toModifier
                ((Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'_') Attribute Result
attr.typ.typname)
                Attribute Result
attr.attribute.atttypmod
            , arrayDepth :: Word
arrayDepth = Int16 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Attribute Result
attr.attribute.attndims
            }
        }

    toModifier :: Text -> Int64 -> [String]
    toModifier :: Text -> Int64 -> [String]
toModifier Text
"bpchar" (-1) = []
    toModifier Text
"bpchar" Int64
n = [Int64 -> String
forall a. Show a => a -> String
show (Int64
n Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
4)]
    toModifier Text
"numeric" (-1) = []
    toModifier Text
"numeric" Int64
n = [Int64 -> String
forall a. Show a => a -> String
show (Int64 -> String) -> Int64 -> String
forall a b. (a -> b) -> a -> b
$ (Int64
n Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
4) Int64 -> Int -> Int64
forall a. Bits a => a -> Int -> a
`shiftR` Int
16, Int64 -> String
forall a. Show a => a -> String
show (Int64 -> String) -> Int64 -> String
forall a b. (a -> b) -> a -> b
$ (Int64
n Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
4) Int64 -> Int64 -> Int64
forall a. Bits a => a -> a -> a
.&. Int64
65535]
    toModifier Text
_ Int64
_ = []

    disjointUnion :: Ord k => M.Map k a -> M.Map k b -> M.Map k (These a b)
    disjointUnion :: forall k a b. Ord k => Map k a -> Map k b -> Map k (These a b)
disjointUnion Map k a
a Map k b
b = (These a b -> These a b -> These a b)
-> Map k (These a b) -> Map k (These a b) -> Map k (These a b)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith These a b -> These a b -> These a b
forall a b. These a b -> These a b -> These a b
go ((a -> These a b) -> Map k a -> Map k (These a b)
forall a b. (a -> b) -> Map k a -> Map k b
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> These a b
forall a b. a -> These a b
This Map k a
a) ((b -> These a b) -> Map k b -> Map k (These a b)
forall a b. (a -> b) -> Map k a -> Map k b
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> These a b
forall a b. b -> These a b
That Map k b
b)
      where
        go :: These a b -> These a b -> These a b
        go :: forall a b. These a b -> These a b -> These a b
go (This a
a) (That b
b) = a -> b -> These a b
forall a b. a -> b -> These a b
These a
a b
b
        go These a b
_ These a b
_ = These a b
forall a. HasCallStack => a
undefined


-- |@pShowTable@ is a helper function which takes a grid of text and prints it
-- as a table, with padding so that cells are lined in columns, and a bordered
-- header for the first row
pShowTable :: [[Text]] -> Text
pShowTable :: [[Text]] -> Text
pShowTable [[Text]]
xs
    = Text -> [Text] -> Text
T.intercalate Text
"\n"
    ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
addHeaderBorder
    ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ ([Text] -> Text) -> [[Text]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> [Text] -> Text
T.intercalate Text
" | ")
    ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [[Text]]
forall a. [[a]] -> [[a]]
L.transpose
    ([[Text]] -> [[Text]]) -> [[Text]] -> [[Text]]
forall a b. (a -> b) -> a -> b
$ [Int] -> [[Text]] -> [(Int, [Text])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
lengths [[Text]]
xs' [(Int, [Text])] -> ((Int, [Text]) -> [Text]) -> [[Text]]
forall (f :: Context) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Int
n, [Text]
column) -> [Text]
column [Text] -> (Text -> Text) -> [Text]
forall (f :: Context) a b. Functor f => f a -> (a -> b) -> f b
<&> \Text
cell -> Int -> Char -> Text -> Text
T.justifyLeft Int
n Char
' ' Text
cell
  where
    addHeaderBorder :: [Text] -> [Text]
    addHeaderBorder :: [Text] -> [Text]
addHeaderBorder [] = []
    addHeaderBorder (Text
x : [Text]
xs) = Text
x Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Int -> Text -> Text
T.replicate (Text -> Int
T.length Text
x) Text
"-" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
xs

    xs' :: [[Text]]
    xs' :: [[Text]]
xs' = [[Text]] -> [[Text]]
forall a. [[a]] -> [[a]]
L.transpose [[Text]]
xs

    lengths :: [Int]
    lengths :: [Int]
lengths = ([Text] -> Int) -> [[Text]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: Context) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> ([Text] -> [Int]) -> [Text] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Int) -> [Text] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Int
T.length) ([[Text]] -> [Int]) -> [[Text]] -> [Int]
forall a b. (a -> b) -> a -> b
$ [[Text]]
xs'


pShowErrors :: [TableInfo] -> Text
pShowErrors :: [TableInfo] -> Text
pShowErrors = Text -> [Text] -> Text
T.intercalate Text
"\n\n" ([Text] -> Text) -> ([TableInfo] -> [Text]) -> [TableInfo] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TableInfo -> Text) -> [TableInfo] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
fmap TableInfo -> Text
go
  where
    go :: TableInfo -> Text
    go :: TableInfo -> Text
go (TableInfo {Bool
tableExists :: Bool
tableExists :: TableInfo -> Bool
tableExists, String
name :: String
name :: TableInfo -> String
name, [ColumnInfo]
columns :: [ColumnInfo]
columns :: TableInfo -> [ColumnInfo]
columns}) = Text
"Table: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
name
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if Bool -> Bool
not Bool
tableExists then Text
" does not exist\n" else Text
"\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [[Text]] -> Text
pShowTable ([Text
"Column Name", Text
"Implied DB type", Text
"Current DB type", Text
"Error"] [Text] -> [[Text]] -> [[Text]]
forall a. a -> [a] -> [a]
: ([ColumnInfo]
columns [ColumnInfo] -> (ColumnInfo -> [Text]) -> [[Text]]
forall (f :: Context) a b. Functor f => f a -> (a -> b) -> f b
<&> \ColumnInfo
column ->
            [ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ColumnInfo
column.name
            , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> (TypeInfo -> String) -> Maybe TypeInfo -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" TypeInfo -> String
showTypeInfo ColumnInfo
column.hsType
            , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> (TypeInfo -> String) -> Maybe TypeInfo -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" TypeInfo -> String
showTypeInfo ColumnInfo
column.dbType
            , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> (ColumnError -> String) -> Maybe ColumnError -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ColumnError -> String
forall a. Show a => a -> String
show ColumnInfo
column.error
            ]))
    go (DuplicateNames {String
name :: TableInfo -> String
name :: String
name, Map String (NonEmpty TypeInfo)
duplicates :: Map String (NonEmpty TypeInfo)
duplicates :: TableInfo -> Map String (NonEmpty TypeInfo)
duplicates}) = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"Table "
        , String -> Text
T.pack (ShowS
forall a. Show a => a -> String
show String
name)
        , Text
" has multiple columns with the same name. This is an error with the Haskell code generating an impossible schema, rather than an error in your current setup of the database itself. Using 'namesFromLabels' can ensure each column has unique names, which is the easiest way to prevent this, but may require changing names in your database to match the new generated names."
        , [[Text]] -> Text
pShowTable ([Text
"DB name", Text
"Haskell label"] [Text] -> [[Text]] -> [[Text]]
forall a. a -> [a] -> [a]
: (Map String (NonEmpty TypeInfo) -> [(String, NonEmpty TypeInfo)]
forall k a. Map k a -> [(k, a)]
M.assocs Map String (NonEmpty TypeInfo)
duplicates [(String, NonEmpty TypeInfo)]
-> ((String, NonEmpty TypeInfo) -> [Text]) -> [[Text]]
forall (f :: Context) a b. Functor f => f a -> (a -> b) -> f b
<&> \(String
name, NonEmpty TypeInfo
typs) ->
            [ String -> Text
T.pack String
name
            , Text -> [Text] -> Text
T.intercalate Text
" " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (TypeInfo -> Text) -> [TypeInfo] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
fmap (\TypeInfo
typ -> Text -> [Text] -> Text
T.intercalate Text
"/" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack TypeInfo
typ.label) ([TypeInfo] -> [Text]) -> [TypeInfo] -> [Text]
forall a b. (a -> b) -> a -> b
$ NonEmpty TypeInfo -> [TypeInfo]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty TypeInfo
typs
            ]))
        ]


data TableInfo
  = TableInfo
    { TableInfo -> Bool
tableExists :: Bool
    , TableInfo -> String
name :: String
    , TableInfo -> [ColumnInfo]
columns :: [ColumnInfo]
    }
  | DuplicateNames
    { name :: String
    , TableInfo -> Map String (NonEmpty TypeInfo)
duplicates :: M.Map String (NonEmpty.NonEmpty TypeInfo)
    }
  deriving (Int -> TableInfo -> ShowS
[TableInfo] -> ShowS
TableInfo -> String
(Int -> TableInfo -> ShowS)
-> (TableInfo -> String)
-> ([TableInfo] -> ShowS)
-> Show TableInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TableInfo -> ShowS
showsPrec :: Int -> TableInfo -> ShowS
$cshow :: TableInfo -> String
show :: TableInfo -> String
$cshowList :: [TableInfo] -> ShowS
showList :: [TableInfo] -> ShowS
Show)

data ColumnInfo = ColumnInfo
    { ColumnInfo -> String
name   :: String
    , ColumnInfo -> Maybe TypeInfo
hsType :: Maybe TypeInfo
    , ColumnInfo -> Maybe TypeInfo
dbType :: Maybe TypeInfo
    , ColumnInfo -> Maybe ColumnError
error :: Maybe ColumnError
    } deriving (Int -> ColumnInfo -> ShowS
[ColumnInfo] -> ShowS
ColumnInfo -> String
(Int -> ColumnInfo -> ShowS)
-> (ColumnInfo -> String)
-> ([ColumnInfo] -> ShowS)
-> Show ColumnInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ColumnInfo -> ShowS
showsPrec :: Int -> ColumnInfo -> ShowS
$cshow :: ColumnInfo -> String
show :: ColumnInfo -> String
$cshowList :: [ColumnInfo] -> ShowS
showList :: [ColumnInfo] -> ShowS
Show)

data ColumnError
    = DbTypeIsNotNullButNotPresentInHsType
    | HsTypeIsPresentButNotPresentInDbType
    | BidirectionalCastDoesNotExist
    deriving (Int -> ColumnError -> ShowS
[ColumnError] -> ShowS
ColumnError -> String
(Int -> ColumnError -> ShowS)
-> (ColumnError -> String)
-> ([ColumnError] -> ShowS)
-> Show ColumnError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ColumnError -> ShowS
showsPrec :: Int -> ColumnError -> ShowS
$cshow :: ColumnError -> String
show :: ColumnError -> String
$cshowList :: [ColumnError] -> ShowS
showList :: [ColumnError] -> ShowS
Show)


showTypeInfo :: TypeInfo -> String
showTypeInfo :: TypeInfo -> String
showTypeInfo TypeInfo
typeInfo = [String] -> String
forall (t :: Context) a. Foldable t => t [a] -> [a]
concat
    [ String
name
    , if [String] -> Bool
forall a. [a] -> Bool
forall (t :: Context) a. Foldable t => t a -> Bool
Prelude.null [String]
modifiers then String
"" else String
"(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
"," [String]
modifiers String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
    , [String] -> String
forall (t :: Context) a. Foldable t => t [a] -> [a]
concat (Int -> String -> [String]
forall a. Int -> a -> [a]
replicate (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral TypeInfo
typeInfo.typeName.arrayDepth) String
"[]")
    , if TypeInfo
typeInfo.isNull then String
"" else String
" NOT NULL"
    ]
  where
    name :: String
name = case TypeInfo
typeInfo.typeName.name of
        QualifiedName String
a Maybe String
Nothing -> ShowS
forall a. Show a => a -> String
show ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'_') String
a)
        QualifiedName String
a (Just String
b) -> ShowS
forall a. Show a => a -> String
show String
b String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"." String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> String
show ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'_') String
a)

    modifiers :: [String]
    modifiers :: [String]
modifiers = TypeInfo
typeInfo.typeName.modifiers


verifySchema :: Rel8able k => CheckEnv -> TableSchema (k Name) -> TableInfo
verifySchema :: forall (k :: HTable).
Rel8able k =>
CheckEnv -> TableSchema (k Name) -> TableInfo
verifySchema CheckEnv
env TableSchema (k Name)
schema = case k Name
-> Either (Map String (NonEmpty TypeInfo)) (Map String TypeInfo)
forall (k :: HTable).
Rel8able k =>
k Name
-> Either (Map String (NonEmpty TypeInfo)) (Map String TypeInfo)
checkedSchemaToTypeMap TableSchema (k Name)
schema.columns of
    Left Map String (NonEmpty TypeInfo)
dups -> String -> Map String (NonEmpty TypeInfo) -> TableInfo
DuplicateNames TableSchema (k Name)
schema.name.name Map String (NonEmpty TypeInfo)
dups
    Right Map String TypeInfo
typeMap -> Map String TypeInfo -> Maybe [Attribute Result] -> TableInfo
go Map String TypeInfo
typeMap Maybe [Attribute Result]
maybeTable
  where
    maybeTable :: Maybe [Attribute Result]
maybeTable = String -> Map String [Attribute Result] -> Maybe [Attribute Result]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TableSchema (k Name)
schema.name.name CheckEnv
env.schemaMap
    go :: Map String TypeInfo -> Maybe [Attribute Result] -> TableInfo
go Map String TypeInfo
typeMap Maybe [Attribute Result]
Nothing = TableInfo
        { tableExists :: Bool
tableExists = Bool
False
        , name :: String
name = TableSchema (k Name)
schema.name.name
        , columns :: [ColumnInfo]
columns = CheckEnv
-> Map String (Attribute Result)
-> Map String TypeInfo
-> [ColumnInfo]
compareTypes CheckEnv
env Map String (Attribute Result)
forall a. Monoid a => a
mempty Map String TypeInfo
typeMap
        }
    go Map String TypeInfo
typeMap (Just [Attribute Result]
attrs) = TableInfo
        { tableExists :: Bool
tableExists = Bool
True
        , name :: String
name = TableSchema (k Name)
schema.name.name
        , columns :: [ColumnInfo]
columns = CheckEnv
-> Map String (Attribute Result)
-> Map String TypeInfo
-> [ColumnInfo]
compareTypes CheckEnv
env ([Attribute Result] -> Map String (Attribute Result)
attrsToMap [Attribute Result]
attrs) Map String TypeInfo
typeMap
        }


fetchCheckEnv :: HS.Statement () CheckEnv
fetchCheckEnv :: Statement () CheckEnv
fetchCheckEnv = Statement () ([PGTable Result], [Cast Result])
fetchSchema Statement () ([PGTable Result], [Cast Result])
-> (([PGTable Result], [Cast Result]) -> CheckEnv)
-> Statement () CheckEnv
forall (f :: Context) a b. Functor f => f a -> (a -> b) -> f b
<&> \([PGTable Result]
tbls, [Cast Result]
casts) -> 
  let tblMap :: Map String [Attribute Result]
tblMap = (PGTable Result -> Map String [Attribute Result])
-> [PGTable Result] -> Map String [Attribute Result]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: Context) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\PGTable {Column Result Text
HList Result (Attribute Result)
name :: forall (f :: Context). PGTable f -> Column f Text
columns :: forall (f :: Context). PGTable f -> HList f (Attribute f)
name :: Column Result Text
columns :: HList Result (Attribute Result)
..} -> String -> [Attribute Result] -> Map String [Attribute Result]
forall k a. k -> a -> Map k a
M.singleton (Text -> String
T.unpack Text
Column Result Text
name) [Attribute Result]
HList Result (Attribute Result)
columns) [PGTable Result]
tbls
      castMap :: [(String, String)]
castMap = (Cast Result -> (String, String))
-> [Cast Result] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\Cast {Column Result Text
PGType Result
source :: forall (f :: Context). Cast f -> PGType f
target :: forall (f :: Context). Cast f -> PGType f
context :: forall (f :: Context). Cast f -> Column f Text
source :: PGType Result
target :: PGType Result
context :: Column Result Text
..} -> (Text -> String
T.unpack PGType Result
source.typname, Text -> String
T.unpack PGType Result
target.typname)) ([Cast Result] -> [(String, String)])
-> [Cast Result] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ (Cast Result -> Bool) -> [Cast Result] -> [Cast Result]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (\Cast {Column Result Text
context :: forall (f :: Context). Cast f -> Column f Text
context :: Column Result Text
context} -> Text
Column Result Text
context Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"i") [Cast Result]
casts
  in Map String [Attribute Result] -> [(String, String)] -> CheckEnv
CheckEnv Map String [Attribute Result]
tblMap [(String, String)]
castMap
 where
  fetchSchema :: HS.Statement () ([PGTable Result], [Cast Result])
  fetchSchema :: Statement () ([PGTable Result], [Cast Result])
fetchSchema = Statement
  (Query (ListTable Expr (PGTable Expr), ListTable Expr (Cast Expr)))
-> Statement () ([PGTable Result], [Cast Result])
forall exprs a.
Serializable exprs a =>
Statement (Query exprs) -> Statement () a
run1 (Statement
   (Query (ListTable Expr (PGTable Expr), ListTable Expr (Cast Expr)))
 -> Statement () ([PGTable Result], [Cast Result]))
-> Statement
     (Query (ListTable Expr (PGTable Expr), ListTable Expr (Cast Expr)))
-> Statement () ([PGTable Result], [Cast Result])
forall a b. (a -> b) -> a -> b
$ Query (ListTable Expr (PGTable Expr), ListTable Expr (Cast Expr))
-> Statement
     (Query (ListTable Expr (PGTable Expr), ListTable Expr (Cast Expr)))
forall a. Table Expr a => Query a -> Statement (Query a)
select (Query (ListTable Expr (PGTable Expr), ListTable Expr (Cast Expr))
 -> Statement
      (Query
         (ListTable Expr (PGTable Expr), ListTable Expr (Cast Expr))))
-> Query
     (ListTable Expr (PGTable Expr), ListTable Expr (Cast Expr))
-> Statement
     (Query (ListTable Expr (PGTable Expr), ListTable Expr (Cast Expr)))
forall a b. (a -> b) -> a -> b
$ (ListTable Expr (PGTable Expr)
 -> ListTable Expr (Cast Expr)
 -> (ListTable Expr (PGTable Expr), ListTable Expr (Cast Expr)))
-> Query (ListTable Expr (PGTable Expr))
-> Query (ListTable Expr (Cast Expr))
-> Query
     (ListTable Expr (PGTable Expr), ListTable Expr (Cast Expr))
forall a b c. (a -> b -> c) -> Query a -> Query b -> Query c
forall (f :: Context) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) Query (ListTable Expr (PGTable Expr))
fetchTables Query (ListTable Expr (Cast Expr))
fetchCasts


-- |@'SomeTableSchema'@ is used to allow the collection of a variety of different
-- @TableSchema@s under a single type, like:
--
-- @
-- userTable :: TableSchema (User Name)
-- orderTable :: TableSchema (Order Name)
--
-- tables :: [SomeTableSchema]
-- tables = [SomeTableSchema userTable, SomeTable orderTable]
-- @
--
-- This is used by @'schemaErrors'@ to conveniently group every table an
-- application relies on for typechecking the postgresql schemas
-- together in a single batch.
data SomeTableSchema where
    -- The ToExpr constraint isn't used here, but can be used to read from the
    -- SomeTableSchema, which can be useful to combine the type checking with more
    -- thorough value-level checking of the validity of existing rows in the
    -- table.
    SomeTableSchema
        :: (ToExprs (k Expr) (GFromExprs k), Rel8able k)
        => TableSchema (k Name) -> SomeTableSchema

-- |@'getSchemaErrors'@ checks whether the provided schemas have the correct PostgreSQL
-- column names and types to allow reading and writing from their equivalent Haskell
-- types, returning a list of errors if that is not the case. The function does not
-- crash on encountering a bug, instead leaving it to the caller to decide how
-- to respond. A schema is valid if:
--
-- 1. for every existing field, the types match
-- 2. all non-nullable columns are present in the hs type
-- 3. no nonexistent columns are present in the hs type
-- 4. no two columns in the same schema share the same name
--
-- It's still possible for a valid schema to allow invalid data, for instance,
-- if using an ADT, which can introduce restrictions on which values are allowed
-- for the column representing the tag, and introduce restrictions on which
-- columns are non-null depending on the value of the tag. However, if the
-- schema is valid rel8 shouldn't be able to write invalid data to the table.
--
-- However, it is possible for migrations to cause valid data to become invalid
-- in ways not detectable by this function, if the migration code changes the
-- schema correctly but doesn't handle the value-level constraints correctly. So
-- it is a good idea to both read from the tables and check the schema for errors
-- in a transaction during the migration. The former will catch value-level
-- bugs, while the latter will help ensure the schema is set up correctly to
-- be able to insert new data.
--
-- This function does nothing to check that the conflict target of an @Upsert@
-- are valid for the schema, nor can it prevent invalid uses of @unsafeDefault@.
-- However, it should be enough to catch the most likely errors.
getSchemaErrors :: [SomeTableSchema] -> HS.Statement () (Maybe Text)
getSchemaErrors :: [SomeTableSchema] -> Statement () (Maybe Text)
getSchemaErrors [SomeTableSchema]
someTables = (CheckEnv -> Maybe Text)
-> Statement () CheckEnv -> Statement () (Maybe Text)
forall a b. (a -> b) -> Statement () a -> Statement () b
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
fmap CheckEnv -> Maybe Text
collectErrors Statement () CheckEnv
fetchCheckEnv
  where
    collectErrors :: CheckEnv -> Maybe Text
    collectErrors :: CheckEnv -> Maybe Text
collectErrors CheckEnv
env
        = ([TableInfo] -> Text) -> Maybe [TableInfo] -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
fmap [TableInfo] -> Text
pShowErrors
        (Maybe [TableInfo] -> Maybe Text)
-> ([SomeTableSchema] -> Maybe [TableInfo])
-> [SomeTableSchema]
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TableInfo] -> Maybe [TableInfo]
filterErrors
        ([TableInfo] -> Maybe [TableInfo])
-> ([SomeTableSchema] -> [TableInfo])
-> [SomeTableSchema]
-> Maybe [TableInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SomeTableSchema -> TableInfo) -> [SomeTableSchema] -> [TableInfo]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
fmap \case
            SomeTableSchema TableSchema (k Name)
t -> CheckEnv -> TableSchema (k Name) -> TableInfo
forall (k :: HTable).
Rel8able k =>
CheckEnv -> TableSchema (k Name) -> TableInfo
verifySchema CheckEnv
env TableSchema (k Name)
t
        ([SomeTableSchema] -> Maybe Text)
-> [SomeTableSchema] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [SomeTableSchema]
someTables

    -- removes each column which is valid for use by rel8, as well as each table
    -- which contains only valid columns
    filterErrors :: [TableInfo] -> Maybe [TableInfo]
    filterErrors :: [TableInfo] -> Maybe [TableInfo]
filterErrors [TableInfo]
tables = case (TableInfo -> Maybe TableInfo) -> [TableInfo] -> [TableInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TableInfo -> Maybe TableInfo
go [TableInfo]
tables of
        [] -> Maybe [TableInfo]
forall a. Maybe a
Nothing
        [TableInfo]
xs -> [TableInfo] -> Maybe [TableInfo]
forall a. a -> Maybe a
Just [TableInfo]
xs
      where
        go :: TableInfo -> Maybe TableInfo
        go :: TableInfo -> Maybe TableInfo
go TableInfo {Bool
String
[ColumnInfo]
tableExists :: TableInfo -> Bool
name :: TableInfo -> String
columns :: TableInfo -> [ColumnInfo]
tableExists :: Bool
name :: String
columns :: [ColumnInfo]
..} = case (ColumnInfo -> Bool) -> [ColumnInfo] -> [ColumnInfo]
forall a. (a -> Bool) -> [a] -> [a]
P.filter (\ColumnInfo
cd -> Maybe ColumnError -> Bool
forall a. Maybe a -> Bool
isJust ColumnInfo
cd.error) [ColumnInfo]
columns of
            [] -> if Bool
tableExists then Maybe TableInfo
forall a. Maybe a
Nothing else TableInfo -> Maybe TableInfo
forall a. a -> Maybe a
Just (TableInfo -> Maybe TableInfo) -> TableInfo -> Maybe TableInfo
forall a b. (a -> b) -> a -> b
$ TableInfo { String
name :: String
name :: String
name , Bool
tableExists :: Bool
tableExists :: Bool
tableExists , columns :: [ColumnInfo]
columns = [] }
            [ColumnInfo]
xs -> TableInfo -> Maybe TableInfo
forall a. a -> Maybe a
Just (TableInfo -> Maybe TableInfo) -> TableInfo -> Maybe TableInfo
forall a b. (a -> b) -> a -> b
$ TableInfo { String
name :: String
name :: String
name , Bool
tableExists :: Bool
tableExists :: Bool
tableExists , columns :: [ColumnInfo]
columns = [ColumnInfo]
xs }
        go DuplicateNames {String
Map String (NonEmpty TypeInfo)
name :: TableInfo -> String
duplicates :: TableInfo -> Map String (NonEmpty TypeInfo)
name :: String
duplicates :: Map String (NonEmpty TypeInfo)
..} = TableInfo -> Maybe TableInfo
forall a. a -> Maybe a
Just (DuplicateNames {String
Map String (NonEmpty TypeInfo)
name :: String
duplicates :: Map String (NonEmpty TypeInfo)
name :: String
duplicates :: Map String (NonEmpty TypeInfo)
..})