{-# LANGUAGE CPP #-}
-- |
-- Module: PgSchema.Generation
-- Copyright: (c) Dmitry Olshansky
-- License: BSD-3-Clause
-- Maintainer: olshanskydr@gmail.com, dima@typeable.io
-- Stability: experimental
--
-- === Generation of type-level database schema definitions
--
-- Typically you build an executable that imports this module
-- and run it to emit the schema definition.
--
module PgSchema.Generation
  (updateSchemaFile, GenNames(..), AddRelation(..)
  , NameNS'(..), NameNS, (->>)
  ) where

import Control.Monad
import Control.Monad.Catch
import Data.Bifunctor
import Data.ByteString as BS hiding (readFile, writeFile)
import Data.Coerce
import Data.Functor
import Data.List qualified as L
import Data.List.NonEmpty as NE
import Data.Map as M
import Data.Maybe as Mb
import Data.Set as S
import Data.String
import Data.Text as T
import Data.Text.IO as T
import Data.Traversable
import Database.PostgreSQL.Simple
import GHC.Int
import GHC.Records
import GHC.TypeLits ( Symbol )
import PgSchema.Ann
import PgSchema.DML.Select
import PgSchema.DML.Select.Types
import PgSchema.Schema
import PgSchema.Schema.Catalog
import PgSchema.Schema.Info
import PgSchema.Types
import PgSchema.Utils.ShowType
import Prelude as P
import System.Directory
import System.Environment


data ExceptionSch
  = ConnectException ByteString SomeException
  | GetDataException (Text, [SomeToField]) SomeException
  deriving Int -> ExceptionSch -> ShowS
[ExceptionSch] -> ShowS
ExceptionSch -> [Char]
(Int -> ExceptionSch -> ShowS)
-> (ExceptionSch -> [Char])
-> ([ExceptionSch] -> ShowS)
-> Show ExceptionSch
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExceptionSch -> ShowS
showsPrec :: Int -> ExceptionSch -> ShowS
$cshow :: ExceptionSch -> [Char]
show :: ExceptionSch -> [Char]
$cshowList :: [ExceptionSch] -> ShowS
showList :: [ExceptionSch] -> ShowS
Show

instance Exception ExceptionSch

data AddRelation = AddRelation
  { AddRelation -> Text
name  :: Text
  -- ^ name of an additional (non-existing in the database) relation.
  -- All additional relations will be added with the namespace "_add".
  , AddRelation -> NameNS
from  :: NameNS
  , AddRelation -> NameNS
to    :: NameNS
  , AddRelation -> [(Text, Text)]
cols  :: [(Text, Text)] }

data GenNames = GenNames
  { GenNames -> [Text]
schemas :: [Text]   -- ^ generate data for all tables in these schemas
  , GenNames -> [NameNS]
tables  :: [NameNS] -- ^ generate data for these tables
  , GenNames -> [AddRelation]
addRelations :: [AddRelation] -- ^ additional relations. Be careful!
  }

type AnnCat tn = 'Ann RenamerId PgCatalog 3 (PGC tn)

selCat :: forall (tn :: Symbol) -> forall r. (Selectable (AnnCat tn) r)
  => Connection -> QueryParam PgCatalog (PGC tn) -> IO ([r], (Text,[SomeToField]))
selCat :: forall (tn :: Symbol) ->
forall r.
Selectable (AnnCat tn) r =>
Connection
-> QueryParam PgCatalog (PGC tn) -> IO ([r], (Text, [SomeToField]))
selCat tn = selectSch (AnnCat tn)

selTxt :: forall (tn :: Symbol) -> forall r. (Selectable (AnnCat tn) r)
  => QueryParam PgCatalog (PGC tn) -> (Text,[SomeToField])
selTxt :: forall (tn :: Symbol) ->
forall r.
Selectable (AnnCat tn) r =>
QueryParam PgCatalog (PGC tn) -> (Text, [SomeToField])
selTxt tn @r = forall (ann :: Ann) ->
forall r.
(CRecInfo ann r, ann ~ AnnCat tn) =>
QueryParam PgCatalog (PGC tn) -> (Text, [SomeToField])
forall r.
(CRecInfo (AnnCat tn) r, AnnCat tn ~ AnnCat tn) =>
QueryParam PgCatalog (PGC tn) -> (Text, [SomeToField])
forall (ren :: Renamer) sch (d :: Natural) (tab :: NameNSK).
forall (ann :: Ann) ->
forall r.
(CRecInfo ann r, ann ~ 'Ann ren sch d tab) =>
QueryParam sch tab -> (Text, [SomeToField])
selectText (AnnCat tn) @r

getSchema
  :: Connection -- ^ connection to PostgreSQL database
  -> GenNames   -- ^ names of schemas and tables to generate from the database
  -> IO ([PgType], [PgClass], [PgRelation])
getSchema :: Connection -> GenNames -> IO ([PgType], [PgClass], [PgRelation])
getSchema Connection
conn GenNames {[Text]
[NameNS]
[AddRelation]
schemas :: GenNames -> [Text]
tables :: GenNames -> [NameNS]
addRelations :: GenNames -> [AddRelation]
schemas :: [Text]
tables :: [NameNS]
addRelations :: [AddRelation]
..} = do
  types <- Connection
-> QueryParam PgCatalog (PGC "pg_type")
-> IO ([PgType], (Text, [SomeToField]))
forall (tn :: Symbol) ->
forall r.
Selectable (AnnCat tn) r =>
Connection
-> QueryParam PgCatalog (PGC tn) -> IO ([r], (Text, [SomeToField]))
forall r.
Selectable (AnnCat "pg_type") r =>
Connection
-> QueryParam PgCatalog (PGC "pg_type")
-> IO ([r], (Text, [SomeToField]))
selCat "pg_type" Connection
conn QueryParam PgCatalog (PGC "pg_type")
qpTyp IO ([PgType], (Text, [SomeToField]))
-> (SomeException -> IO ([PgType], (Text, [SomeToField])))
-> IO ([PgType], (Text, [SomeToField]))
forall e a.
(HasCallStack, Exception e) =>
IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch`
    (ExceptionSch -> IO ([PgType], (Text, [SomeToField]))
forall e a. (HasCallStack, Exception e) => e -> IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ExceptionSch -> IO ([PgType], (Text, [SomeToField])))
-> (SomeException -> ExceptionSch)
-> SomeException
-> IO ([PgType], (Text, [SomeToField]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, [SomeToField]) -> SomeException -> ExceptionSch
GetDataException (forall (tn :: Symbol) ->
forall r.
Selectable (AnnCat tn) r =>
QueryParam PgCatalog (PGC tn) -> (Text, [SomeToField])
forall r.
Selectable (AnnCat "pg_type") r =>
QueryParam PgCatalog (PGC "pg_type") -> (Text, [SomeToField])
selTxt "pg_type" @PgType QueryParam PgCatalog (PGC "pg_type")
qpTyp))
  classes <- L.filter checkClass . fst <$> selCat "pg_class" conn qpClass `catch`
    (throwM . GetDataException (selTxt "pg_class" @PgClass qpClass))
  relations <- L.filter checkRels . (Mb.mapMaybe (mkRel classes) addRelations <>)
    . fst <$> selCat "pg_constraint" conn qpRel `catch`
      (throwM . GetDataException (selTxt "pg_constraint" @PgRelation qpRel))
  pure (fst types, classes, relations)
  where
    mkRel :: t r -> r -> Maybe PgRelation
mkRel t r
classes r
ar = do
      conkey <- r -> [a] -> Maybe (PgArr Int16)
mkNums r
ar.from ([a] -> Maybe (PgArr Int16)) -> [a] -> Maybe (PgArr Int16)
forall a b. (a -> b) -> a -> b
$ (a, a) -> a
forall a b. (a, b) -> a
fst ((a, a) -> a) -> [(a, a)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> r
ar.cols
      confkey <- mkNums ar.to $ snd <$> ar.cols
      pure PgRelation
        { constraint__namespace = "nspname" =: "_add"
        , conname               = ar.name
        , constraint__class     = toPgClassShort ar.from
        , constraint__fclass    = toPgClassShort ar.to
        , .. }
      where
        toPgClassShort :: r -> PgClassShort
toPgClassShort r
nns = PgClassShort
          { class__namespace :: "nspname" := Text
class__namespace = "nspname" Text -> "nspname" := Text
forall (a :: Symbol) -> Text -> a := Text
forall {k} b. forall (a :: k) -> b -> a := b
=: r
nns.nnsNamespace
          , relname :: Text
relname          = r
nns.nnsName }
        mkNums :: r -> [a] -> Maybe (PgArr Int16)
mkNums r
nns [a]
fields = do
          pgcl <- (r -> Bool) -> t r -> Maybe r
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (\r
c -> r
c.class__namespace ("nspname" := Text) -> ("nspname" := Text) -> Bool
forall a. Eq a => a -> a -> Bool
== "nspname" Text -> "nspname" := Text
forall (a :: Symbol) -> Text -> a := Text
forall {k} b. forall (a :: k) -> b -> a := b
=: r
nns.nnsNamespace
            Bool -> Bool -> Bool
&& r
c.relname Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== r
nns.nnsName) t r
classes
          inds <- for fields \a
fld ->
            (a -> Bool) -> [a] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
L.findIndex ((a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
fld) (a -> Bool) -> (a -> a) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.attname)) r
pgcl.attribute__class
          pure $ pgArr' $ fromIntegral . (+1) <$> inds

-- all data are ordered to provide stable `hashSchema`
    qpTyp :: QueryParam PgCatalog (PGC "pg_type")
qpTyp = forall {a} sch (t :: NameNSK).
RWS (Proxy '[]) () (QueryParam sch t) () -> QueryParam sch t
forall sch (t :: NameNSK).
RWS (Proxy '[]) () (QueryParam sch t) () -> QueryParam sch t
qRoot @PgCatalog @(PGC "pg_type") do
      [OrdFld PgCatalog (TabOnPath PgCatalog (PGC "pg_type") '[])]
-> MonadQP PgCatalog (PGC "pg_type") '[]
forall sch (t :: NameNSK) (path :: [Symbol]).
[OrdFld sch (TabOnPath sch t path)] -> MonadQP sch t path
qOrderBy [ascf "typname", Text -> OrdFld PgCatalog (PGC "pg_type")
forall {k} {sch :: k} {tab :: NameNSK}. Text -> OrdFld sch tab
ordNS Text
"typnamespace"]
      (TabPath PgCatalog (PGC "pg_type") '["enum__type"],
 ToStar '["enum__type"],
 '["enum__type"] ~ ('[] ++ '["enum__type"])) =>
MonadQP PgCatalog (PGC "pg_type") '["enum__type"]
-> MonadQP PgCatalog (PGC "pg_type") '[]
MonadQP PgCatalog (PGC "pg_type") '["enum__type"]
-> MonadQP PgCatalog (PGC "pg_type") '[]
forall (p :: Symbol) ->
(TabPath PgCatalog (PGC "pg_type") '["enum__type"],
 ToStar '["enum__type"], '["enum__type"] ~ ('[] ++ '[p])) =>
MonadQP PgCatalog (PGC "pg_type") '["enum__type"]
-> MonadQP PgCatalog (PGC "pg_type") '[]
forall sch (t :: NameNSK) (path :: [Symbol]) (path' :: [Symbol]).
forall (p :: Symbol) ->
(TabPath sch t path', ToStar path', path' ~ (path ++ '[p])) =>
MonadQP sch t path' -> MonadQP sch t path
qPath "enum__type" do
        [OrdFld
   PgCatalog (TabOnPath PgCatalog (PGC "pg_type") '["enum__type"])]
-> MonadQP PgCatalog (PGC "pg_type") '["enum__type"]
forall sch (t :: NameNSK) (path :: [Symbol]).
[OrdFld sch (TabOnPath sch t path)] -> MonadQP sch t path
qOrderBy [ascf "enumsortorder"]
    qpClass :: QueryParam PgCatalog ('NameNS "pg_catalog" "pg_class")
qpClass = forall {a} sch (t :: NameNSK).
RWS (Proxy '[]) () (QueryParam sch t) () -> QueryParam sch t
forall sch (t :: NameNSK).
RWS (Proxy '[]) () (QueryParam sch t) () -> QueryParam sch t
qRoot @PgCatalog @(PGC "pg_class") do
      Cond
  PgCatalog
  (TabOnPath PgCatalog ('NameNS "pg_catalog" "pg_class") '[])
-> MonadQP PgCatalog ('NameNS "pg_catalog" "pg_class") '[]
forall sch (t :: NameNSK) (path :: [Symbol]).
Cond sch (TabOnPath sch t path) -> MonadQP sch t path
qWhere (Cond
   PgCatalog
   (TabOnPath PgCatalog ('NameNS "pg_catalog" "pg_class") '[])
 -> MonadQP PgCatalog ('NameNS "pg_catalog" "pg_class") '[])
-> Cond
     PgCatalog
     (TabOnPath PgCatalog ('NameNS "pg_catalog" "pg_class") '[])
-> MonadQP PgCatalog ('NameNS "pg_catalog" "pg_class") '[]
forall a b. (a -> b) -> a -> b
$ Cond
  PgCatalog
  (TabOnPath PgCatalog ('NameNS "pg_catalog" "pg_class") '[])
Cond PgCatalog ('NameNS "pg_catalog" "pg_class")
condClass Cond
  PgCatalog
  (TabOnPath PgCatalog ('NameNS "pg_catalog" "pg_class") '[])
-> Cond
     PgCatalog
     (TabOnPath PgCatalog ('NameNS "pg_catalog" "pg_class") '[])
-> Cond
     PgCatalog
     (TabOnPath PgCatalog ('NameNS "pg_catalog" "pg_class") '[])
forall sch (tab :: NameNSK).
Cond sch tab -> Cond sch tab -> Cond sch tab
&&& NonEmpty PgChar -> Cond PgCatalog ('NameNS "pg_catalog" "pg_class")
forall (name :: Symbol) ->
forall sch (tab :: NameNSK) (fd :: FldDef' Symbol) v.
CDBValue sch tab name fd v =>
NonEmpty v -> Cond sch tab
forall sch (tab :: NameNSK) (fd :: FldDef' Symbol) v.
CDBValue sch tab "relkind" fd v =>
NonEmpty v -> Cond sch tab
pin "relkind" (Char -> PgChar
PgChar (Char -> PgChar) -> NonEmpty Char -> NonEmpty PgChar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char
'v' Char -> [Char] -> NonEmpty Char
forall a. a -> [a] -> NonEmpty a
:| [Char]
"r") -- views & tables
      [OrdFld
   PgCatalog
   (TabOnPath PgCatalog ('NameNS "pg_catalog" "pg_class") '[])]
-> MonadQP PgCatalog ('NameNS "pg_catalog" "pg_class") '[]
forall sch (t :: NameNSK) (path :: [Symbol]).
[OrdFld sch (TabOnPath sch t path)] -> MonadQP sch t path
qOrderBy [ascf "relname", Text -> OrdFld PgCatalog ('NameNS "pg_catalog" "pg_class")
forall {k} {sch :: k} {tab :: NameNSK}. Text -> OrdFld sch tab
ordNS Text
"relnamespace"]
      (TabPath
   PgCatalog ('NameNS "pg_catalog" "pg_class") '["attribute__class"],
 ToStar '["attribute__class"],
 '["attribute__class"] ~ ('[] ++ '["attribute__class"])) =>
MonadQP
  PgCatalog ('NameNS "pg_catalog" "pg_class") '["attribute__class"]
-> MonadQP PgCatalog ('NameNS "pg_catalog" "pg_class") '[]
MonadQP
  PgCatalog ('NameNS "pg_catalog" "pg_class") '["attribute__class"]
-> MonadQP PgCatalog ('NameNS "pg_catalog" "pg_class") '[]
forall (p :: Symbol) ->
(TabPath
   PgCatalog ('NameNS "pg_catalog" "pg_class") '["attribute__class"],
 ToStar '["attribute__class"],
 '["attribute__class"] ~ ('[] ++ '[p])) =>
MonadQP
  PgCatalog ('NameNS "pg_catalog" "pg_class") '["attribute__class"]
-> MonadQP PgCatalog ('NameNS "pg_catalog" "pg_class") '[]
forall sch (t :: NameNSK) (path :: [Symbol]) (path' :: [Symbol]).
forall (p :: Symbol) ->
(TabPath sch t path', ToStar path', path' ~ (path ++ '[p])) =>
MonadQP sch t path' -> MonadQP sch t path
qPath "attribute__class" do
        Cond
  PgCatalog
  (TabOnPath
     PgCatalog ('NameNS "pg_catalog" "pg_class") '["attribute__class"])
-> MonadQP
     PgCatalog ('NameNS "pg_catalog" "pg_class") '["attribute__class"]
forall sch (t :: NameNSK) (path :: [Symbol]).
Cond sch (TabOnPath sch t path) -> MonadQP sch t path
qWhere (Cond
   PgCatalog
   (TabOnPath
      PgCatalog ('NameNS "pg_catalog" "pg_class") '["attribute__class"])
 -> MonadQP
      PgCatalog ('NameNS "pg_catalog" "pg_class") '["attribute__class"])
-> Cond
     PgCatalog
     (TabOnPath
        PgCatalog ('NameNS "pg_catalog" "pg_class") '["attribute__class"])
-> MonadQP
     PgCatalog ('NameNS "pg_catalog" "pg_class") '["attribute__class"]
forall a b. (a -> b) -> a -> b
$ "attnum" Int16
-> Cond
     PgCatalog
     (TabOnPath
        PgCatalog ('NameNS "pg_catalog" "pg_class") '["attribute__class"])
forall (fld :: Symbol) ->
forall sch (tab :: NameNSK) (fd :: FldDef' Symbol) v.
CDBValue sch tab fld fd v =>
v -> Cond sch tab
forall sch (tab :: NameNSK) (fd :: FldDef' Symbol) v.
CDBValue sch tab "attnum" fd v =>
v -> Cond sch tab
>? (Int16
0::Int16)
        [OrdFld
   PgCatalog
   (TabOnPath
      PgCatalog ('NameNS "pg_catalog" "pg_class") '["attribute__class"])]
-> MonadQP
     PgCatalog ('NameNS "pg_catalog" "pg_class") '["attribute__class"]
forall sch (t :: NameNSK) (path :: [Symbol]).
[OrdFld sch (TabOnPath sch t path)] -> MonadQP sch t path
qOrderBy [ascf "attnum"]
      (TabPath
   PgCatalog ('NameNS "pg_catalog" "pg_class") '["constraint__class"],
 ToStar '["constraint__class"],
 '["constraint__class"] ~ ('[] ++ '["constraint__class"])) =>
MonadQP
  PgCatalog ('NameNS "pg_catalog" "pg_class") '["constraint__class"]
-> MonadQP PgCatalog ('NameNS "pg_catalog" "pg_class") '[]
MonadQP
  PgCatalog ('NameNS "pg_catalog" "pg_class") '["constraint__class"]
-> MonadQP PgCatalog ('NameNS "pg_catalog" "pg_class") '[]
forall (p :: Symbol) ->
(TabPath
   PgCatalog ('NameNS "pg_catalog" "pg_class") '["constraint__class"],
 ToStar '["constraint__class"],
 '["constraint__class"] ~ ('[] ++ '[p])) =>
MonadQP
  PgCatalog ('NameNS "pg_catalog" "pg_class") '["constraint__class"]
-> MonadQP PgCatalog ('NameNS "pg_catalog" "pg_class") '[]
forall sch (t :: NameNSK) (path :: [Symbol]) (path' :: [Symbol]).
forall (p :: Symbol) ->
(TabPath sch t path', ToStar path', path' ~ (path ++ '[p])) =>
MonadQP sch t path' -> MonadQP sch t path
qPath "constraint__class" do
        [OrdFld
   PgCatalog
   (TabOnPath
      PgCatalog
      ('NameNS "pg_catalog" "pg_class")
      '["constraint__class"])]
-> MonadQP
     PgCatalog ('NameNS "pg_catalog" "pg_class") '["constraint__class"]
forall sch (t :: NameNSK) (path :: [Symbol]).
[OrdFld sch (TabOnPath sch t path)] -> MonadQP sch t path
qOrderBy [ascf "conname"]
    qpRel :: QueryParam PgCatalog (PGC "pg_constraint")
qpRel = forall {a} sch (t :: NameNSK).
RWS (Proxy '[]) () (QueryParam sch t) () -> QueryParam sch t
forall sch (t :: NameNSK).
RWS (Proxy '[]) () (QueryParam sch t) () -> QueryParam sch t
qRoot @PgCatalog @(PGC "pg_constraint") do
      Cond PgCatalog (TabOnPath PgCatalog (PGC "pg_constraint") '[])
-> MonadQP PgCatalog (PGC "pg_constraint") '[]
forall sch (t :: NameNSK) (path :: [Symbol]).
Cond sch (TabOnPath sch t path) -> MonadQP sch t path
qWhere
        (Cond PgCatalog (TabOnPath PgCatalog (PGC "pg_constraint") '[])
 -> MonadQP PgCatalog (PGC "pg_constraint") '[])
-> Cond PgCatalog (TabOnPath PgCatalog (PGC "pg_constraint") '[])
-> MonadQP PgCatalog (PGC "pg_constraint") '[]
forall a b. (a -> b) -> a -> b
$   CRelDef PgCatalog (PGC "constraint__class") =>
Cond PgCatalog (RdTo (TRelDef PgCatalog (PGC "constraint__class")))
-> Cond
     PgCatalog (RdFrom (TRelDef PgCatalog (PGC "constraint__class")))
Cond PgCatalog (RdTo (TRelDef PgCatalog (PGC "constraint__class")))
-> Cond
     PgCatalog (RdFrom (TRelDef PgCatalog (PGC "constraint__class")))
forall (ref :: NameNSK) ->
CRelDef PgCatalog ref =>
Cond PgCatalog (RdTo (TRelDef PgCatalog ref))
-> Cond PgCatalog (RdFrom (TRelDef PgCatalog ref))
forall sch.
forall (ref :: NameNSK) ->
CRelDef sch ref =>
Cond sch (RdTo (TRelDef sch ref))
-> Cond sch (RdFrom (TRelDef sch ref))
pparent (PGC "constraint__class") Cond PgCatalog ('NameNS "pg_catalog" "pg_class")
Cond PgCatalog (RdTo (TRelDef PgCatalog (PGC "constraint__class")))
condClass
        Cond PgCatalog (TabOnPath PgCatalog (PGC "pg_constraint") '[])
-> Cond PgCatalog (TabOnPath PgCatalog (PGC "pg_constraint") '[])
-> Cond PgCatalog (TabOnPath PgCatalog (PGC "pg_constraint") '[])
forall sch (tab :: NameNSK).
Cond sch tab -> Cond sch tab -> Cond sch tab
||| CRelDef PgCatalog (PGC "constraint__fclass") =>
Cond
  PgCatalog (RdTo (TRelDef PgCatalog (PGC "constraint__fclass")))
-> Cond
     PgCatalog (RdFrom (TRelDef PgCatalog (PGC "constraint__fclass")))
Cond
  PgCatalog (RdTo (TRelDef PgCatalog (PGC "constraint__fclass")))
-> Cond
     PgCatalog (RdFrom (TRelDef PgCatalog (PGC "constraint__fclass")))
forall (ref :: NameNSK) ->
CRelDef PgCatalog ref =>
Cond PgCatalog (RdTo (TRelDef PgCatalog ref))
-> Cond PgCatalog (RdFrom (TRelDef PgCatalog ref))
forall sch.
forall (ref :: NameNSK) ->
CRelDef sch ref =>
Cond sch (RdTo (TRelDef sch ref))
-> Cond sch (RdFrom (TRelDef sch ref))
pparent (PGC "constraint__fclass") Cond PgCatalog ('NameNS "pg_catalog" "pg_class")
Cond
  PgCatalog (RdTo (TRelDef PgCatalog (PGC "constraint__fclass")))
condClass
      [OrdFld PgCatalog (TabOnPath PgCatalog (PGC "pg_constraint") '[])]
-> MonadQP PgCatalog (PGC "pg_constraint") '[]
forall sch (t :: NameNSK) (path :: [Symbol]).
[OrdFld sch (TabOnPath sch t path)] -> MonadQP sch t path
qOrderBy [ascf "conname", Text -> OrdFld PgCatalog (PGC "pg_constraint")
forall {k} {sch :: k} {tab :: NameNSK}. Text -> OrdFld sch tab
ordNS Text
"connamespace"]
    ordNS :: Text -> OrdFld sch tab
ordNS Text
fld = CondMonad (Text, OrdDirection) -> OrdFld sch tab
forall {k} (sch :: k) (tab :: NameNSK).
CondMonad (Text, OrdDirection) -> OrdFld sch tab
UnsafeOrd do
      o <- CondMonad Text
tabPref
      pure ("(select nspname from pg_catalog.pg_namespace p where p.oid = "
        <> o <> "." <> fld <> ")", Asc)
    condClass :: Cond PgCatalog ('NameNS "pg_catalog" "pg_class")
condClass = Cond PgCatalog ('NameNS "pg_catalog" "pg_class")
Cond
  PgCatalog (RdFrom (TRelDef PgCatalog (PGC "class__namespace")))
condSchemas Cond PgCatalog ('NameNS "pg_catalog" "pg_class")
-> Cond PgCatalog ('NameNS "pg_catalog" "pg_class")
-> Cond PgCatalog ('NameNS "pg_catalog" "pg_class")
forall sch (tab :: NameNSK).
Cond sch tab -> Cond sch tab -> Cond sch tab
||| Cond PgCatalog ('NameNS "pg_catalog" "pg_class")
condTabs
      where
        condSchemas :: Cond
  PgCatalog (RdFrom (TRelDef PgCatalog (PGC "class__namespace")))
condSchemas = pparent (PGC "class__namespace")
          (Cond PgCatalog (RdTo (TRelDef PgCatalog (PGC "class__namespace")))
 -> Cond
      PgCatalog (RdFrom (TRelDef PgCatalog (PGC "class__namespace"))))
-> Cond
     PgCatalog (RdTo (TRelDef PgCatalog (PGC "class__namespace")))
-> Cond
     PgCatalog (RdFrom (TRelDef PgCatalog (PGC "class__namespace")))
forall a b. (a -> b) -> a -> b
$ (NonEmpty Text
 -> Cond
      PgCatalog (RdTo (TRelDef PgCatalog (PGC "class__namespace"))))
-> Maybe (NonEmpty Text)
-> Cond
     PgCatalog (RdTo (TRelDef PgCatalog (PGC "class__namespace")))
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (pin "nspname") (Maybe (NonEmpty Text)
 -> Cond
      PgCatalog (RdTo (TRelDef PgCatalog (PGC "class__namespace"))))
-> Maybe (NonEmpty Text)
-> Cond
     PgCatalog (RdTo (TRelDef PgCatalog (PGC "class__namespace")))
forall a b. (a -> b) -> a -> b
$ [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Text]
schemas
        condTabs :: Cond PgCatalog ('NameNS "pg_catalog" "pg_class")
condTabs
          = CRelDef PgCatalog (PGC "class__namespace") =>
Cond PgCatalog (RdTo (TRelDef PgCatalog (PGC "class__namespace")))
-> Cond
     PgCatalog (RdFrom (TRelDef PgCatalog (PGC "class__namespace")))
Cond PgCatalog (RdTo (TRelDef PgCatalog (PGC "class__namespace")))
-> Cond
     PgCatalog (RdFrom (TRelDef PgCatalog (PGC "class__namespace")))
forall (ref :: NameNSK) ->
CRelDef PgCatalog ref =>
Cond PgCatalog (RdTo (TRelDef PgCatalog ref))
-> Cond PgCatalog (RdFrom (TRelDef PgCatalog ref))
forall sch.
forall (ref :: NameNSK) ->
CRelDef sch ref =>
Cond sch (RdTo (TRelDef sch ref))
-> Cond sch (RdFrom (TRelDef sch ref))
pparent (PGC "class__namespace")
            ((NonEmpty NameNS
 -> Cond PgCatalog ('NameNS "pg_catalog" "pg_namespace"))
-> Maybe (NonEmpty NameNS)
-> Cond PgCatalog ('NameNS "pg_catalog" "pg_namespace")
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (pin "nspname" (NonEmpty Text
 -> Cond PgCatalog ('NameNS "pg_catalog" "pg_namespace"))
-> (NonEmpty NameNS -> NonEmpty Text)
-> NonEmpty NameNS
-> Cond PgCatalog ('NameNS "pg_catalog" "pg_namespace")
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NameNS -> Text) -> NonEmpty NameNS -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NameNS -> Text
forall s. NameNS' s -> s
nnsNamespace) ([NameNS] -> Maybe (NonEmpty NameNS)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [NameNS]
tables))
          Cond PgCatalog ('NameNS "pg_catalog" "pg_class")
-> Cond PgCatalog ('NameNS "pg_catalog" "pg_class")
-> Cond PgCatalog ('NameNS "pg_catalog" "pg_class")
forall sch (tab :: NameNSK).
Cond sch tab -> Cond sch tab -> Cond sch tab
&&& (NonEmpty NameNS
 -> Cond PgCatalog ('NameNS "pg_catalog" "pg_class"))
-> Maybe (NonEmpty NameNS)
-> Cond PgCatalog ('NameNS "pg_catalog" "pg_class")
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (pin "relname" (NonEmpty Text -> Cond PgCatalog ('NameNS "pg_catalog" "pg_class"))
-> (NonEmpty NameNS -> NonEmpty Text)
-> NonEmpty NameNS
-> Cond PgCatalog ('NameNS "pg_catalog" "pg_class")
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NameNS -> Text) -> NonEmpty NameNS -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NameNS -> Text
forall s. NameNS' s -> s
nnsName) ([NameNS] -> Maybe (NonEmpty NameNS)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [NameNS]
tables)
    checkClass :: PgClass -> Bool
checkClass PgClass {[PgConstraint]
[PgAttribute]
Text
"nspname" := Text
PgChar
class__namespace :: "nspname" := Text
relname :: Text
relkind :: PgChar
attribute__class :: [PgAttribute]
constraint__class :: [PgConstraint]
constraint__class :: PgClass -> [PgConstraint]
attribute__class :: PgClass -> [PgAttribute]
relkind :: PgClass -> PgChar
relname :: PgClass -> Text
class__namespace :: PgClass -> "nspname" := Text
..}
      = (("nspname" := Text) -> Text
forall a b. Coercible a b => a -> b
coerce "nspname" := Text
class__namespace Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [Text]
schemas)
      Bool -> Bool -> Bool
|| (("nspname" := Text) -> Text
forall a b. Coercible a b => a -> b
coerce "nspname" := Text
class__namespace Text -> Text -> NameNS
->> Text
relname NameNS -> [NameNS] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [NameNS]
tables)
    checkRels :: PgRelation -> Bool
checkRels PgRelation {Text
"nspname" := Text
PgArr Int16
PgClassShort
constraint__namespace :: PgRelation -> "nspname" := Text
conname :: PgRelation -> Text
constraint__class :: PgRelation -> PgClassShort
constraint__fclass :: PgRelation -> PgClassShort
confkey :: PgRelation -> PgArr Int16
conkey :: PgRelation -> PgArr Int16
constraint__namespace :: "nspname" := Text
conname :: Text
constraint__class :: PgClassShort
constraint__fclass :: PgClassShort
conkey :: PgArr Int16
confkey :: PgArr Int16
..} =
      PgClassShort -> Bool
check PgClassShort
constraint__class Bool -> Bool -> Bool
|| PgClassShort -> Bool
check PgClassShort
constraint__fclass
      where
        check :: PgClassShort -> Bool
check PgClassShort {Text
"nspname" := Text
class__namespace :: PgClassShort -> "nspname" := Text
relname :: PgClassShort -> Text
class__namespace :: "nspname" := Text
relname :: Text
..}
          = (("nspname" := Text) -> Text
forall a b. Coercible a b => a -> b
coerce "nspname" := Text
class__namespace Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [Text]
schemas)
          Bool -> Bool -> Bool
|| (("nspname" := Text) -> Text
forall a b. Coercible a b => a -> b
coerce "nspname" := Text
class__namespace Text -> Text -> NameNS
->> Text
relname NameNS -> [NameNS] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [NameNS]
tables)

getDefs
  :: ([PgType], [PgClass], [PgRelation])
  -> (Map NameNS TypDef
    , Map (NameNS,Text) FldDef
    , Map NameNS (TabDef, [NameNS], [NameNS])
    , Map NameNS RelDef)
getDefs :: ([PgType], [PgClass], [PgRelation])
-> (Map NameNS TypDef, Map (NameNS, Text) FldDef,
    Map NameNS (TabDef, [NameNS], [NameNS]), Map NameNS RelDef)
getDefs ([PgType]
types,[PgClass]
classes,[PgRelation]
relations) =
  ( [(NameNS, TypDef)] -> Map NameNS TypDef
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(NameNS, TypDef)] -> Map NameNS TypDef)
-> [(NameNS, TypDef)] -> Map NameNS TypDef
forall a b. (a -> b) -> a -> b
$ (PgType, Maybe NameNS) -> (NameNS, TypDef)
ptypDef ((PgType, Maybe NameNS) -> (NameNS, TypDef))
-> [(PgType, Maybe NameNS)] -> [(NameNS, TypDef)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PgType, Maybe NameNS)]
ntypes
  , [((NameNS, Text), FldDef)] -> Map (NameNS, Text) FldDef
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((NameNS, Text), FldDef)] -> Map (NameNS, Text) FldDef)
-> [((NameNS, Text), FldDef)] -> Map (NameNS, Text) FldDef
forall a b. (a -> b) -> a -> b
$ (NameNS, PgAttribute) -> ((NameNS, Text), FldDef)
pfldDef ((NameNS, PgAttribute) -> ((NameNS, Text), FldDef))
-> [(NameNS, PgAttribute)] -> [((NameNS, Text), FldDef)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(NameNS, PgAttribute)]
attrs
  , [(NameNS, (TabDef, [NameNS], [NameNS]))]
-> Map NameNS (TabDef, [NameNS], [NameNS])
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(NameNS, (TabDef, [NameNS], [NameNS]))]
 -> Map NameNS (TabDef, [NameNS], [NameNS]))
-> [(NameNS, (TabDef, [NameNS], [NameNS]))]
-> Map NameNS (TabDef, [NameNS], [NameNS])
forall a b. (a -> b) -> a -> b
$ PgClass -> (NameNS, (TabDef, [NameNS], [NameNS]))
ptabDef (PgClass -> (NameNS, (TabDef, [NameNS], [NameNS])))
-> [PgClass] -> [(NameNS, (TabDef, [NameNS], [NameNS]))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PgClass]
classes
  , [(NameNS, RelDef)] -> Map NameNS RelDef
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(NameNS, RelDef)]
relDefs )
  where
    classAttrs :: [(NameNS, [PgAttribute])]
classAttrs = ((,) (NameNS -> [PgAttribute] -> (NameNS, [PgAttribute]))
-> (PgClass -> NameNS)
-> PgClass
-> [PgAttribute]
-> (NameNS, [PgAttribute])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PgClass -> NameNS
forall r.
(HasField "class__namespace" r ("nspname" := Text),
 HasField "relname" r Text) =>
r -> NameNS
tabKey (PgClass -> [PgAttribute] -> (NameNS, [PgAttribute]))
-> (PgClass -> [PgAttribute]) -> PgClass -> (NameNS, [PgAttribute])
forall a b. (PgClass -> a -> b) -> (PgClass -> a) -> PgClass -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PgClass -> [PgAttribute]
attribute__class) (PgClass -> (NameNS, [PgAttribute]))
-> [PgClass] -> [(NameNS, [PgAttribute])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PgClass]
classes
    mClassAttrs :: Map (NameNS, Int16) Text
mClassAttrs =
      [((NameNS, Int16), Text)] -> Map (NameNS, Int16) Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [((NameNS
c, PgAttribute -> Int16
attnum PgAttribute
a), PgAttribute -> Text
attname PgAttribute
a)| (NameNS
c,[PgAttribute]
as) <- [(NameNS, [PgAttribute])]
classAttrs, PgAttribute
a <- [PgAttribute]
as]
    [(NameNS, PgAttribute)]
attrs :: [(NameNS, PgAttribute)] =
      ((NameNS, [PgAttribute]) -> [(NameNS, PgAttribute)])
-> [(NameNS, [PgAttribute])] -> [(NameNS, PgAttribute)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
L.concatMap (\(NameNS
a,[PgAttribute]
xs) -> (NameNS
a,) (PgAttribute -> (NameNS, PgAttribute))
-> [PgAttribute] -> [(NameNS, PgAttribute)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PgAttribute]
xs) [(NameNS, [PgAttribute])]
classAttrs
    typKey :: PgType -> NameNS
typKey = Text -> Text -> NameNS
forall s. s -> s -> NameNS' s
NameNS (Text -> Text -> NameNS)
-> (PgType -> Text) -> PgType -> Text -> NameNS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (("nspname" := Text) -> Text
forall a b. Coercible a b => a -> b
coerce (("nspname" := Text) -> Text)
-> (PgType -> "nspname" := Text) -> PgType -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PgType -> "nspname" := Text
type__namespace) (PgType -> Text -> NameNS) -> (PgType -> Text) -> PgType -> NameNS
forall a b. (PgType -> a -> b) -> (PgType -> a) -> PgType -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PgType -> Text
typname
    ntypes :: [(PgType, Maybe NameNS)]
ntypes = PgType -> (PgType, Maybe NameNS)
ntype (PgType -> (PgType, Maybe NameNS))
-> [PgType] -> [(PgType, Maybe NameNS)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PgType -> Bool) -> [PgType] -> [PgType]
forall a. (a -> Bool) -> [a] -> [a]
L.filter ((NameNS -> Set NameNS -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set NameNS
attrsTypes) (NameNS -> Bool) -> (PgType -> NameNS) -> PgType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PgType -> NameNS
typKey) [PgType]
types
      where
        ntype :: PgType -> (PgType, Maybe NameNS)
ntype PgType
t = (PgType
t, PgType -> NameNS
typKey (PgType -> NameNS) -> Maybe PgType -> Maybe NameNS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Oid -> Map Oid PgType -> Maybe PgType
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (PgOid -> Oid
fromPgOid (PgOid -> Oid) -> PgOid -> Oid
forall a b. (a -> b) -> a -> b
$ PgType -> PgOid
typelem PgType
t) Map Oid PgType
mtypes)
        attrsTypes :: Set NameNS
attrsTypes = [NameNS] -> Set NameNS
forall a. Ord a => [a] -> Set a
S.fromList ([NameNS] -> Set NameNS) -> [NameNS] -> Set NameNS
forall a b. (a -> b) -> a -> b
$ (PgType -> NameNS
typKey (PgType -> NameNS)
-> ((NameNS, PgAttribute) -> PgType)
-> (NameNS, PgAttribute)
-> NameNS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PgAttribute -> PgType
attribute__type (PgAttribute -> PgType)
-> ((NameNS, PgAttribute) -> PgAttribute)
-> (NameNS, PgAttribute)
-> PgType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NameNS, PgAttribute) -> PgAttribute
forall a b. (a, b) -> b
snd ((NameNS, PgAttribute) -> NameNS)
-> [(NameNS, PgAttribute)] -> [NameNS]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(NameNS, PgAttribute)]
attrs)
          [NameNS] -> [NameNS] -> [NameNS]
forall a. Semigroup a => a -> a -> a
<> [Text -> NameNS
pgc Text
"int8", Text -> NameNS
pgc Text
"float8"] -- added for Aggr
        mtypes :: Map Oid PgType
mtypes = [(Oid, PgType)] -> Map Oid PgType
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Oid, PgType)] -> Map Oid PgType)
-> [(Oid, PgType)] -> Map Oid PgType
forall a b. (a -> b) -> a -> b
$ (\PgType
x -> (PgOid -> Oid
fromPgOid (PgOid -> Oid) -> PgOid -> Oid
forall a b. (a -> b) -> a -> b
$ PgType -> PgOid
oid PgType
x , PgType
x)) (PgType -> (Oid, PgType)) -> [PgType] -> [(Oid, PgType)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PgType]
types
    ptypDef :: (PgType, Maybe NameNS) -> (NameNS, TypDef)
ptypDef (x :: PgType
x@PgType{[PgEnum]
Text
"nspname" := Text
PgOid
PgChar
type__namespace :: PgType -> "nspname" := Text
typname :: PgType -> Text
typelem :: PgType -> PgOid
oid :: PgType -> PgOid
oid :: PgOid
type__namespace :: "nspname" := Text
typname :: Text
typcategory :: PgChar
typelem :: PgOid
enum__type :: [PgEnum]
enum__type :: PgType -> [PgEnum]
typcategory :: PgType -> PgChar
..}, Maybe NameNS
typElem) = (PgType -> NameNS
typKey PgType
x, TypDef {[Text]
Maybe NameNS
Text
typElem :: Maybe NameNS
typCategory :: Text
typEnum :: [Text]
typEnum :: [Text]
typElem :: Maybe NameNS
typCategory :: Text
..})
      where
        typCategory :: Text
typCategory = Char -> Text
T.singleton (Char -> Text) -> Char -> Text
forall a b. (a -> b) -> a -> b
$ PgChar -> Char
forall a b. Coercible a b => a -> b
coerce PgChar
typcategory
        typEnum :: [Text]
typEnum = PgEnum -> Text
enumlabel (PgEnum -> Text) -> [PgEnum] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PgEnum] -> [PgEnum]
forall a b. Coercible a b => a -> b
coerce [PgEnum]
enum__type
    pfldDef :: (NameNS, PgAttribute) -> ((NameNS, Text), FldDef)
pfldDef (NameNS
cname::NameNS, PgAttribute{Bool
Int16
Text
PgType
attnum :: PgAttribute -> Int16
attname :: PgAttribute -> Text
attribute__type :: PgAttribute -> PgType
attname :: Text
attribute__type :: PgType
attnum :: Int16
attnotnull :: Bool
atthasdef :: Bool
atthasdef :: PgAttribute -> Bool
attnotnull :: PgAttribute -> Bool
..}) = ((NameNS
cname,Text
attname), FldDef{Bool
NameNS
fdType :: NameNS
fdNullable :: Bool
fdHasDefault :: Bool
fdHasDefault :: Bool
fdNullable :: Bool
fdType :: NameNS
..})
      where
        fdType :: NameNS
fdType = PgType -> NameNS
typKey PgType
attribute__type
        fdNullable :: Bool
fdNullable = Bool -> Bool
not Bool
attnotnull
        fdHasDefault :: Bool
fdHasDefault = Bool
atthasdef
    tabKey
      :: forall r .
        ( HasField "class__namespace" r ("nspname" := Text)
        , HasField "relname" r Text )
      => r -> NameNS
    tabKey :: forall r.
(HasField "class__namespace" r ("nspname" := Text),
 HasField "relname" r Text) =>
r -> NameNS
tabKey r
r = Text -> Text -> NameNS
forall s. s -> s -> NameNS' s
NameNS (("nspname" := Text) -> Text
forall a b. Coercible a b => a -> b
coerce r
r.class__namespace) r
r.relname
    ptabDef :: PgClass -> (NameNS, (TabDef, [NameNS], [NameNS]))
ptabDef c :: PgClass
c@PgClass{[PgConstraint]
[PgAttribute]
Text
"nspname" := Text
PgChar
constraint__class :: PgClass -> [PgConstraint]
attribute__class :: PgClass -> [PgAttribute]
relkind :: PgClass -> PgChar
relname :: PgClass -> Text
class__namespace :: PgClass -> "nspname" := Text
class__namespace :: "nspname" := Text
relname :: Text
relkind :: PgChar
attribute__class :: [PgAttribute]
constraint__class :: [PgConstraint]
..} = (NameNS
tabName, (TabDef{[[Text]]
[Text]
tdFlds :: [Text]
tdKey :: [Text]
tdUniq :: [[Text]]
tdUniq :: [[Text]]
tdKey :: [Text]
tdFlds :: [Text]
..}, [NameNS]
froms, [NameNS]
tos))
      where
        tabName :: NameNS
tabName = PgClass -> NameNS
forall r.
(HasField "class__namespace" r ("nspname" := Text),
 HasField "relname" r Text) =>
r -> NameNS
tabKey PgClass
c
        tdFlds :: [Text]
tdFlds = PgAttribute -> Text
attname (PgAttribute -> Text) -> [PgAttribute] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PgAttribute] -> [PgAttribute]
forall a b. Coercible a b => a -> b
coerce [PgAttribute]
attribute__class
        tdKey :: [Text]
tdKey = [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> [[Text]]
keysBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'p')
        tdUniq :: [[Text]]
tdUniq = (Char -> Bool) -> [[Text]]
keysBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'u')
        keysBy :: (Char -> Bool) -> [[Text]]
keysBy Char -> Bool
f
          = (PgConstraint -> Maybe [Text]) -> [PgConstraint] -> [[Text]]
forall a b. (a -> Maybe b) -> [a] -> [b]
Mb.mapMaybe -- if something is wrong exclude such constraint
          ((Int16 -> Maybe Text) -> [Int16] -> Maybe [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Int16 -> Maybe Text
numToName ([Int16] -> Maybe [Text])
-> (PgConstraint -> [Int16]) -> PgConstraint -> Maybe [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PgArr Int16 -> [Int16]
forall a. PgArr a -> [a]
unPgArr' (PgArr Int16 -> [Int16])
-> (PgConstraint -> PgArr Int16) -> PgConstraint -> [Int16]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.conkey))
          ([PgConstraint] -> [[Text]]) -> [PgConstraint] -> [[Text]]
forall a b. (a -> b) -> a -> b
$ (PgConstraint -> Bool) -> [PgConstraint] -> [PgConstraint]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (Char -> Bool
f (Char -> Bool) -> (PgConstraint -> Char) -> PgConstraint -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PgChar -> Char
forall a b. Coercible a b => a -> b
coerce (PgChar -> Char)
-> (PgConstraint -> PgChar) -> PgConstraint -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PgConstraint -> PgChar
contype) ([PgConstraint] -> [PgConstraint]
forall a b. Coercible a b => a -> b
coerce [PgConstraint]
constraint__class)
          where
            numToName :: Int16 -> Maybe Text
numToName Int16
a =
              PgAttribute -> Text
attname (PgAttribute -> Text) -> Maybe PgAttribute -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PgAttribute -> Bool) -> [PgAttribute] -> Maybe PgAttribute
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ((Int16 -> Int16 -> Bool
forall a. Eq a => a -> a -> Bool
==Int16
a) (Int16 -> Bool) -> (PgAttribute -> Int16) -> PgAttribute -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PgAttribute -> Int16
attnum) [PgAttribute]
attribute__class
        ([NameNS]
froms, [NameNS]
tos) = ((RelDef -> NameNS) -> [NameNS])
-> ((RelDef -> NameNS) -> [NameNS])
-> (RelDef -> NameNS, RelDef -> NameNS)
-> ([NameNS], [NameNS])
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (RelDef -> NameNS) -> [NameNS]
getNames (RelDef -> NameNS) -> [NameNS]
getNames (RelDef -> NameNS
forall s. RelDef' s -> NameNS' s
rdFrom, RelDef -> NameNS
forall s. RelDef' s -> NameNS' s
rdTo)
          where
            getNames :: (RelDef -> NameNS) -> [NameNS]
getNames RelDef -> NameNS
f = (NameNS, RelDef) -> NameNS
forall a b. (a, b) -> a
fst ((NameNS, RelDef) -> NameNS) -> [(NameNS, RelDef)] -> [NameNS]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((NameNS, RelDef) -> Bool)
-> [(NameNS, RelDef)] -> [(NameNS, RelDef)]
forall a. (a -> Bool) -> [a] -> [a]
L.filter ((NameNS -> NameNS -> Bool
forall a. Eq a => a -> a -> Bool
==NameNS
tabName) (NameNS -> Bool)
-> ((NameNS, RelDef) -> NameNS) -> (NameNS, RelDef) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelDef -> NameNS
f (RelDef -> NameNS)
-> ((NameNS, RelDef) -> RelDef) -> (NameNS, RelDef) -> NameNS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NameNS, RelDef) -> RelDef
forall a b. (a, b) -> b
snd) [(NameNS, RelDef)]
relDefs
    relDefs :: [(NameNS, RelDef)]
relDefs = (PgRelation -> Maybe (NameNS, RelDef))
-> [PgRelation] -> [(NameNS, RelDef)]
forall a b. (a -> Maybe b) -> [a] -> [b]
Mb.mapMaybe PgRelation -> Maybe (NameNS, RelDef)
mbRelDef [PgRelation]
relations
    mbRelDef :: PgRelation -> Maybe (NameNS, RelDef)
mbRelDef PgRelation {Text
"nspname" := Text
PgArr Int16
PgClassShort
constraint__namespace :: PgRelation -> "nspname" := Text
conname :: PgRelation -> Text
constraint__class :: PgRelation -> PgClassShort
constraint__fclass :: PgRelation -> PgClassShort
confkey :: PgRelation -> PgArr Int16
conkey :: PgRelation -> PgArr Int16
constraint__namespace :: "nspname" := Text
conname :: Text
constraint__class :: PgClassShort
constraint__fclass :: PgClassShort
conkey :: PgArr Int16
confkey :: PgArr Int16
..} = (NameNS, Maybe RelDef) -> Maybe (NameNS, RelDef)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
(NameNS, f a) -> f (NameNS, a)
sequenceA
      ( NameNS
rdName
      , (Int16 -> Int16 -> Maybe (Text, Text))
-> [Int16] -> [Int16] -> Maybe [(Text, Text)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Int16 -> Int16 -> Maybe (Text, Text)
getName2 (PgArr Int16 -> [Int16]
forall a. PgArr a -> [a]
unPgArr' PgArr Int16
conkey) (PgArr Int16 -> [Int16]
forall a. PgArr a -> [a]
unPgArr' PgArr Int16
confkey)
        Maybe [(Text, Text)] -> ([(Text, Text)] -> RelDef) -> Maybe RelDef
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \[(Text, Text)]
rdCols -> RelDef{[(Text, Text)]
NameNS
rdFrom :: NameNS
rdTo :: NameNS
rdCols :: [(Text, Text)]
rdFrom :: NameNS
rdTo :: NameNS
rdCols :: [(Text, Text)]
..})
      where
        rdName :: NameNS
rdName = Text -> Text -> NameNS
forall s. s -> s -> NameNS' s
NameNS (("nspname" := Text) -> Text
forall a b. Coercible a b => a -> b
coerce "nspname" := Text
constraint__namespace) Text
conname
        rdFrom :: NameNS
rdFrom = PgClassShort -> NameNS
forall r.
(HasField "class__namespace" r ("nspname" := Text),
 HasField "relname" r Text) =>
r -> NameNS
tabKey PgClassShort
constraint__class
        rdTo :: NameNS
rdTo = PgClassShort -> NameNS
forall r.
(HasField "class__namespace" r ("nspname" := Text),
 HasField "relname" r Text) =>
r -> NameNS
tabKey PgClassShort
constraint__fclass
        getName :: NameNS -> Int16 -> Maybe Text
getName NameNS
t Int16
n = (NameNS, Int16) -> Map (NameNS, Int16) Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (NameNS
t,Int16
n) Map (NameNS, Int16) Text
mClassAttrs
        getName2 :: Int16 -> Int16 -> Maybe (Text, Text)
getName2 Int16
n1 Int16
n2 = (,) (Text -> Text -> (Text, Text))
-> Maybe Text -> Maybe (Text -> (Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameNS -> Int16 -> Maybe Text
getName NameNS
rdFrom Int16
n1 Maybe (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NameNS -> Int16 -> Maybe Text
getName NameNS
rdTo Int16
n2

-- | Update (or create) the Haskell file containing the schema definition
updateSchemaFile
  :: Bool       -- ^ verbose mode
  -> String     -- ^ file name
  -> Either String ByteString
    -- ^ name of environment variable with connection string, or
    -- the connection string itself.
    -- When this environment variable is not set or the connection string is empty,
    -- we do nothing.
  -> Text     -- ^ haskell module name to generate
  -> Text     -- ^ name of generated haskell type for schema
  -> GenNames -- ^ names of schemas in database or tables to generate
  -> IO Bool
updateSchemaFile :: Bool
-> [Char]
-> Either [Char] ByteString
-> Text
-> Text
-> GenNames
-> IO Bool
updateSchemaFile Bool
verbose [Char]
fileName Either [Char] ByteString
ecs Text
moduleName Text
schName GenNames
genNames = do
  connStr <- ([Char] -> IO ByteString)
-> (ByteString -> IO ByteString)
-> Either [Char] ByteString
-> IO ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> IO ByteString
forall {a}. IsString a => [Char] -> IO a
getConnStr ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either [Char] ByteString
ecs
  if BS.null connStr
    then pure False
    else do
      fe <- doesFileExist fileName
      conn <- connectPostgreSQL connStr
      P.putStrLn "Trying to get schema"
      schema <- getSchema conn genNames
      P.putStrLn "Generation"
      let newTxt = ([PgType], [PgClass], [PgRelation]) -> Text
moduleText ([PgType], [PgClass], [PgRelation])
schema
      needGen <- if fe
        then (/= newTxt) <$> T.readFile fileName
        else pure True
      P.putStrLn $ "Need to generate file: " <> P.show needGen
      when needGen do
        when fe $ copyFile fileName (fileName <> ".bak")
        T.writeFile fileName newTxt
      when verbose $ print schema
      pure needGen
  where
    getConnStr :: [Char] -> IO a
getConnStr [Char]
env =
      (SomeException -> IO a) -> IO a -> IO a
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (forall a b. a -> b -> a
const @_ @SomeException (IO a -> SomeException -> IO a) -> IO a -> SomeException -> IO a
forall a b. (a -> b) -> a -> b
$ a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
"") ([Char] -> a
forall a. IsString a => [Char] -> a
fromString ([Char] -> a) -> IO [Char] -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
getEnv [Char]
env)
    moduleText :: ([PgType], [PgClass], [PgRelation]) -> Text
moduleText = Text
-> Text
-> (Map NameNS TypDef, Map (NameNS, Text) FldDef,
    Map NameNS (TabDef, [NameNS], [NameNS]), Map NameNS RelDef)
-> Text
genModuleText Text
moduleName Text
schName ((Map NameNS TypDef, Map (NameNS, Text) FldDef,
  Map NameNS (TabDef, [NameNS], [NameNS]), Map NameNS RelDef)
 -> Text)
-> (([PgType], [PgClass], [PgRelation])
    -> (Map NameNS TypDef, Map (NameNS, Text) FldDef,
        Map NameNS (TabDef, [NameNS], [NameNS]), Map NameNS RelDef))
-> ([PgType], [PgClass], [PgRelation])
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([PgType], [PgClass], [PgRelation])
-> (Map NameNS TypDef, Map (NameNS, Text) FldDef,
    Map NameNS (TabDef, [NameNS], [NameNS]), Map NameNS RelDef)
getDefs

mkInst :: ShowType a => Text -> [Text] -> a -> Text
mkInst :: forall a. ShowType a => Text -> [Text] -> a -> Text
mkInst Text
name [Text]
pars a
a
  =  Text
"instance C" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sgn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where\n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"  type T" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sgn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = \n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> a -> Text
forall a. ShowType a => Int -> Int -> a -> Text
showSplit Int
6 Int
70 a
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
  where
    sgn :: Text
sgn = Text -> [Text] -> Text
T.intercalate Text
" " (Text
name Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
pars)

textTypDef :: Text -> NameNS -> TypDef -> Text
textTypDef :: Text -> NameNS -> TypDef -> Text
textTypDef Text
sch NameNS
typ td :: TypDef
td@TypDef {[Text]
Maybe NameNS
Text
typEnum :: forall s. TypDef' s -> [s]
typElem :: forall s. TypDef' s -> Maybe (NameNS' s)
typCategory :: forall s. TypDef' s -> s
typCategory :: Text
typElem :: Maybe NameNS
typEnum :: [Text]
..} = Text -> [Text] -> TypDef -> Text
forall a. ShowType a => Text -> [Text] -> a -> Text
mkInst Text
"TypDef" [Text]
ss TypDef
td Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pgEnum
  where
    ss :: [Text]
ss = [Text
sch, NameNS -> Text
forall a. ShowType a => a -> Text
showType NameNS
typ]
    st :: Text
st = Text -> [Text] -> Text
T.intercalate Text
" " [Text]
ss
    pgEnum :: Text
pgEnum
      | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [Text]
typEnum = Text
""
      | Bool
otherwise
        = Text
"data instance PGEnum " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
st Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n  = "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Int -> Int -> Text -> Text
showSplit' Text
"|" Int
2 Int
70
          ( Text -> [Text] -> Text
T.intercalate Text
" | "
            ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((Text -> Text
T.toTitle (NameNS -> Text
forall s. NameNS' s -> s
nnsName NameNS
typ) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
typEnum )
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"  deriving (Show, Read, Ord, Eq, Generic, Bounded, Enum)\n\n"
#ifdef MK_HASHABLE
        <> "instance Hashable (PGEnum " <> st <> ")\n\n"
#endif
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"instance NFData (PGEnum " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
st Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")\n\n"

textTabDef :: Text -> NameNS -> TabDef -> Text
textTabDef :: Text -> NameNS -> TabDef -> Text
textTabDef Text
sch NameNS
tab = Text -> [Text] -> TabDef -> Text
forall a. ShowType a => Text -> [Text] -> a -> Text
mkInst Text
"TabDef" [Text
sch, NameNS -> Text
forall a. ShowType a => a -> Text
showType NameNS
tab]

textRelDef :: Text -> NameNS -> RelDef -> Text
textRelDef :: Text -> NameNS -> RelDef -> Text
textRelDef Text
sch NameNS
relName RelDef
rel =
  Text
"instance CRelDef " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sch Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NameNS -> Text
forall a. ShowType a => a -> Text
showType NameNS
relName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
  Text
"  type TRelDef " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sch Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NameNS -> Text
forall a. ShowType a => a -> Text
showType NameNS
relName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RelDef -> Text
forall a. ShowType a => a -> Text
showType RelDef
rel Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n"

textTabRel :: Text -> NameNS -> [NameNS] -> [NameNS] -> Text
textTabRel :: Text -> NameNS -> [NameNS] -> [NameNS] -> Text
textTabRel Text
sch NameNS
tab [NameNS]
froms [NameNS]
tos
  =  Text
"instance CTabRels " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pars Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where\n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"  type TFrom " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pars Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = \n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> [NameNS] -> Text
forall a. ShowType a => Int -> Int -> a -> Text
showSplit Int
6 Int
70 [NameNS]
froms Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"  type TTo " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pars Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = \n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> [NameNS] -> Text
forall a. ShowType a => Int -> Int -> a -> Text
showSplit Int
6 Int
70 [NameNS]
tos Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
  where
    pars :: Text
pars = Text -> [Text] -> Text
T.intercalate Text
" " [Text
sch, NameNS -> Text
forall a. ShowType a => a -> Text
showType NameNS
tab]

-- Generate Ref in type-level format (using 'FldDef directly)
textRef :: FldDef -> FldDef -> Text -> Text -> Text
textRef :: FldDef -> FldDef -> Text -> Text -> Text
textRef FldDef
fromDef FldDef
toDef Text
fromName Text
toName =
  Text
"'Ref " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. ShowType a => a -> Text
showType Text
fromName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FldDef -> Text
forall a. ShowType a => a -> Text
showType FldDef
fromDef Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") "
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. ShowType a => a -> Text
showType Text
toName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FldDef -> Text
forall a. ShowType a => a -> Text
showType FldDef
toDef Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

-- RHS only (for closed type family equations)
rhsPlain :: FldDef -> Text
rhsPlain :: FldDef -> Text
rhsPlain FldDef
fd = Text
"'RFPlain (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FldDef -> Text
forall a. ShowType a => a -> Text
showType FldDef
fd Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

rhsToHere :: NameNS -> NameNS -> RelDef -> M.Map (NameNS, Text) FldDef -> Text
rhsToHere :: NameNS -> NameNS -> RelDef -> Map (NameNS, Text) FldDef -> Text
rhsToHere NameNS
tab NameNS
fromTab RelDef
rel Map (NameNS, Text) FldDef
mfld =
  let refsText :: Text
refsText = Text -> [Text] -> Text
T.intercalate Text
"\n      , " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
        [ FldDef -> FldDef -> Text -> Text -> Text
textRef (Map (NameNS, Text) FldDef
mfld Map (NameNS, Text) FldDef -> (NameNS, Text) -> FldDef
forall k a. Ord k => Map k a -> k -> a
M.! (NameNS
fromTab, Text
fromName)) (Map (NameNS, Text) FldDef
mfld Map (NameNS, Text) FldDef -> (NameNS, Text) -> FldDef
forall k a. Ord k => Map k a -> k -> a
M.! (NameNS
tab, Text
toName)) Text
fromName Text
toName
        | (Text
fromName, Text
toName) <- RelDef -> [(Text, Text)]
forall s. RelDef' s -> [(s, s)]
rdCols RelDef
rel
        ]
  in Text
"'RFToHere " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NameNS -> Text
forall a. ShowType a => a -> Text
showType NameNS
fromTab Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n      '[ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
refsText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]"

rhsFromHere :: NameNS -> NameNS -> RelDef -> M.Map (NameNS, Text) FldDef -> Text
rhsFromHere :: NameNS -> NameNS -> RelDef -> Map (NameNS, Text) FldDef -> Text
rhsFromHere NameNS
tab NameNS
toTab RelDef
rel Map (NameNS, Text) FldDef
mfld =
  let refsText :: Text
refsText = Text -> [Text] -> Text
T.intercalate Text
"\n      , " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
        [ FldDef -> FldDef -> Text -> Text -> Text
textRef (Map (NameNS, Text) FldDef
mfld Map (NameNS, Text) FldDef -> (NameNS, Text) -> FldDef
forall k a. Ord k => Map k a -> k -> a
M.! (NameNS
tab, Text
fromName)) (Map (NameNS, Text) FldDef
mfld Map (NameNS, Text) FldDef -> (NameNS, Text) -> FldDef
forall k a. Ord k => Map k a -> k -> a
M.! (NameNS
toTab, Text
toName)) Text
fromName Text
toName
        | (Text
fromName, Text
toName) <- RelDef -> [(Text, Text)]
forall s. RelDef' s -> [(s, s)]
rdCols RelDef
rel
        ]
  in Text
"'RFFromHere " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NameNS -> Text
forall a. ShowType a => a -> Text
showType NameNS
toTab Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n      '[ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
refsText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]"

rhsSelfRef :: NameNS -> RelDef -> M.Map (NameNS, Text) FldDef -> Text
rhsSelfRef :: NameNS -> RelDef -> Map (NameNS, Text) FldDef -> Text
rhsSelfRef NameNS
tab RelDef
rel Map (NameNS, Text) FldDef
mfld =
  let refsText :: Text
refsText = Text -> [Text] -> Text
T.intercalate Text
"\n      , " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
        [ FldDef -> FldDef -> Text -> Text -> Text
textRef (Map (NameNS, Text) FldDef
mfld Map (NameNS, Text) FldDef -> (NameNS, Text) -> FldDef
forall k a. Ord k => Map k a -> k -> a
M.! (NameNS
tab, Text
fromName)) (Map (NameNS, Text) FldDef
mfld Map (NameNS, Text) FldDef -> (NameNS, Text) -> FldDef
forall k a. Ord k => Map k a -> k -> a
M.! (NameNS
tab, Text
toName)) Text
fromName Text
toName
        | (Text
fromName, Text
toName) <- RelDef -> [(Text, Text)]
forall s. RelDef' s -> [(s, s)]
rdCols RelDef
rel
        ]
  in Text
"'RFSelfRef " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NameNS -> Text
forall a. ShowType a => a -> Text
showType NameNS
tab Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n      '[ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
refsText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]"

-- Closed type family TDBFieldInfo<Sch> and single CDBFieldInfo instance
typeFamilyName :: Text -> Text
typeFamilyName :: Text -> Text
typeFamilyName Text
sch = Text
"TDBFieldInfo" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sch

typeErrorMsg
  :: Text -> Text -> [Text] -> [Text] -> Text
typeErrorMsg :: Text -> Text -> [Text] -> [Text] -> Text
typeErrorMsg Text
sch Text
tabStr [Text]
fields [Text]
rels =
  Text
"TE.TypeError (TE.Text \"In schema \" TE.:<>: TE.ShowType " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sch
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n    TE.:$$: TE.Text \"for table \" TE.:<>: TE.ShowType " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tabStr
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n    TE.:$$: TE.Text \"name \" TE.:<>: TE.ShowType f TE.:<>: TE.Text \" is not defined.\""
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n    TE.:$$: TE.Text \"\""
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n    TE.:$$: TE.Text \"Valid values are:\""
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n    TE.:$$: TE.Text \"  Fields: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
fields Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".\""
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n    TE.:$$: TE.Text \"  Foreign key constraints: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
rels Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".\""
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n    TE.:$$: TE.Text \"\""
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n    TE.:$$: TE.Text \"Your source or target type or renaimer is probably invalid.\""
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n    TE.:$$: TE.Text \"\""
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

textClosedFieldInfoTF
  :: Text
  -> (M.Map (NameNS, Text) FldDef
    , M.Map NameNS (TabDef, [NameNS]
    , [NameNS]), M.Map NameNS RelDef)
  -> Text
textClosedFieldInfoTF :: Text
-> (Map (NameNS, Text) FldDef,
    Map NameNS (TabDef, [NameNS], [NameNS]), Map NameNS RelDef)
-> Text
textClosedFieldInfoTF Text
schName (Map (NameNS, Text) FldDef
mfld, Map NameNS (TabDef, [NameNS], [NameNS])
mtab, Map NameNS RelDef
mrel) =
  Text
"type family " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tfName
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (t :: NameNSK) (f :: TL.Symbol) :: RecFieldK NameNSK where\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
equations Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"instance (ToStar (TDBFieldInfo " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
schName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" t f), ToStar t, ToStar f) => CDBFieldInfo " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
schName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" t f where\n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"  type TDBFieldInfo " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
schName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" t f = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tfName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" t f\n\n"
  where
    tfName :: Text
tfName = Text -> Text
typeFamilyName Text
schName
      -- All (tab, fldName, rhs) in deterministic order: by table, then plain fields,
      -- then toHere, then fromHere, then selfRef (for self-FK).
    plainEntries :: [(NameNS, Text, Text)]
plainEntries =
      [ (NameNS
tab, Text
fldName, FldDef -> Text
rhsPlain FldDef
fd) | ((NameNS
tab, Text
fldName), FldDef
fd) <- Map (NameNS, Text) FldDef -> [((NameNS, Text), FldDef)]
forall k a. Map k a -> [(k, a)]
M.toList Map (NameNS, Text) FldDef
mfld ]
    toHereEntries :: [(NameNS, Text, Text)]
toHereEntries =
      [ (NameNS
tab, NameNS -> Text
forall s. NameNS' s -> s
nnsName NameNS
relName, NameNS -> NameNS -> RelDef -> Map (NameNS, Text) FldDef -> Text
rhsToHere NameNS
tab (RelDef -> NameNS
forall s. RelDef' s -> NameNS' s
rdFrom RelDef
rel) RelDef
rel Map (NameNS, Text) FldDef
mfld)
      | (NameNS
tab, (TabDef
_, [NameNS]
_froms, [NameNS]
tos)) <- Map NameNS (TabDef, [NameNS], [NameNS])
-> [(NameNS, (TabDef, [NameNS], [NameNS]))]
forall k a. Map k a -> [(k, a)]
M.toList Map NameNS (TabDef, [NameNS], [NameNS])
mtab, NameNS
relName <- [NameNS]
tos
      , let rel :: RelDef
rel = Map NameNS RelDef
mrel Map NameNS RelDef -> NameNS -> RelDef
forall k a. Ord k => Map k a -> k -> a
M.! NameNS
relName
      , Bool -> Bool
not (RelDef -> NameNS
forall s. RelDef' s -> NameNS' s
rdFrom RelDef
rel NameNS -> NameNS -> Bool
forall a. Eq a => a -> a -> Bool
== NameNS
tab Bool -> Bool -> Bool
&& RelDef -> NameNS
forall s. RelDef' s -> NameNS' s
rdTo RelDef
rel NameNS -> NameNS -> Bool
forall a. Eq a => a -> a -> Bool
== NameNS
tab)
      ]
    fromHereEntries :: [(NameNS, Text, Text)]
fromHereEntries =
      [ (NameNS
tab, NameNS -> Text
forall s. NameNS' s -> s
nnsName NameNS
relName, NameNS -> NameNS -> RelDef -> Map (NameNS, Text) FldDef -> Text
rhsFromHere NameNS
tab (RelDef -> NameNS
forall s. RelDef' s -> NameNS' s
rdTo RelDef
rel) RelDef
rel Map (NameNS, Text) FldDef
mfld)
      | (NameNS
tab, (TabDef
_, [NameNS]
froms, [NameNS]
_tos)) <- Map NameNS (TabDef, [NameNS], [NameNS])
-> [(NameNS, (TabDef, [NameNS], [NameNS]))]
forall k a. Map k a -> [(k, a)]
M.toList Map NameNS (TabDef, [NameNS], [NameNS])
mtab, NameNS
relName <- [NameNS]
froms
      , let rel :: RelDef
rel = Map NameNS RelDef
mrel Map NameNS RelDef -> NameNS -> RelDef
forall k a. Ord k => Map k a -> k -> a
M.! NameNS
relName
      , Bool -> Bool
not (RelDef -> NameNS
forall s. RelDef' s -> NameNS' s
rdFrom RelDef
rel NameNS -> NameNS -> Bool
forall a. Eq a => a -> a -> Bool
== NameNS
tab Bool -> Bool -> Bool
&& RelDef -> NameNS
forall s. RelDef' s -> NameNS' s
rdTo RelDef
rel NameNS -> NameNS -> Bool
forall a. Eq a => a -> a -> Bool
== NameNS
tab)
      ]
    selfEntries :: [(NameNS, Text, Text)]
selfEntries =
      [ (NameNS
tab, NameNS -> Text
forall s. NameNS' s -> s
nnsName NameNS
relName, NameNS -> RelDef -> Map (NameNS, Text) FldDef -> Text
rhsSelfRef NameNS
tab RelDef
rel Map (NameNS, Text) FldDef
mfld)
      | (NameNS
tab, (TabDef
_, [NameNS]
froms, [NameNS]
tos)) <- Map NameNS (TabDef, [NameNS], [NameNS])
-> [(NameNS, (TabDef, [NameNS], [NameNS]))]
forall k a. Map k a -> [(k, a)]
M.toList Map NameNS (TabDef, [NameNS], [NameNS])
mtab
      , NameNS
relName <- [NameNS] -> [NameNS]
forall a. Eq a => [a] -> [a]
L.nub ([NameNS]
tos [NameNS] -> [NameNS] -> [NameNS]
forall a. Semigroup a => a -> a -> a
<> [NameNS]
froms)
      , let rel :: RelDef
rel = Map NameNS RelDef
mrel Map NameNS RelDef -> NameNS -> RelDef
forall k a. Ord k => Map k a -> k -> a
M.! NameNS
relName
      , RelDef -> NameNS
forall s. RelDef' s -> NameNS' s
rdFrom RelDef
rel NameNS -> NameNS -> Bool
forall a. Eq a => a -> a -> Bool
== NameNS
tab Bool -> Bool -> Bool
&& RelDef -> NameNS
forall s. RelDef' s -> NameNS' s
rdTo RelDef
rel NameNS -> NameNS -> Bool
forall a. Eq a => a -> a -> Bool
== NameNS
tab
      ]
    allEntries :: [(NameNS, Text, Text)]
allEntries = [(NameNS, Text, Text)]
plainEntries [(NameNS, Text, Text)]
-> [(NameNS, Text, Text)] -> [(NameNS, Text, Text)]
forall a. Semigroup a => a -> a -> a
<> [(NameNS, Text, Text)]
toHereEntries [(NameNS, Text, Text)]
-> [(NameNS, Text, Text)] -> [(NameNS, Text, Text)]
forall a. Semigroup a => a -> a -> a
<> [(NameNS, Text, Text)]
fromHereEntries [(NameNS, Text, Text)]
-> [(NameNS, Text, Text)] -> [(NameNS, Text, Text)]
forall a. Semigroup a => a -> a -> a
<> [(NameNS, Text, Text)]
selfEntries
    eqnLine :: NameNS -> Text -> Text -> Text
eqnLine NameNS
tab Text
fldName Text
rhs =
      Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tfName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NameNS -> Text
forall a. ShowType a => a -> Text
showType NameNS
tab Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fldName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rhs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
    perTableDefault :: NameNS -> Text -> [Text] -> [Text] -> Text
perTableDefault NameNS
_ Text
tabStr [Text]
fieldNames [Text]
relNames =
      Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tfName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tabStr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" f = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> [Text] -> [Text] -> Text
typeErrorMsg Text
schName Text
tabStr [Text]
fieldNames [Text]
relNames Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
    tableBlocks :: [Text]
tableBlocks =
      [ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [ NameNS -> Text -> Text -> Text
eqnLine NameNS
tab Text
fld Text
rhs | (NameNS
t, Text
fld, Text
rhs) <- [(NameNS, Text, Text)]
allEntries, NameNS
t NameNS -> NameNS -> Bool
forall a. Eq a => a -> a -> Bool
== NameNS
tab ]
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NameNS -> Text -> [Text] -> [Text] -> Text
perTableDefault NameNS
tab (NameNS -> Text
forall a. ShowType a => a -> Text
showType NameNS
tab) (TabDef -> [Text]
forall s. TabDef' s -> [s]
tdFlds TabDef
td) ((NameNS -> Text
forall s. NameNS' s -> s
nnsName (NameNS -> Text) -> [NameNS] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NameNS]
froms) [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (NameNS -> Text
forall s. NameNS' s -> s
nnsName (NameNS -> Text) -> [NameNS] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NameNS]
tos))
      | (NameNS
tab, (TabDef
td, [NameNS]
froms, [NameNS]
tos)) <- Map NameNS (TabDef, [NameNS], [NameNS])
-> [(NameNS, (TabDef, [NameNS], [NameNS]))]
forall k a. Map k a -> [(k, a)]
M.toList Map NameNS (TabDef, [NameNS], [NameNS])
mtab ]
    equations :: Text
equations = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text]
tableBlocks Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tfName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" t f = "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
typeErrorMsgFinal Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
    typeErrorMsgFinal :: Text
typeErrorMsgFinal =
      Text
"TE.TypeError (TE.Text \"In schema \" TE.:<>: TE.ShowType " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
schName
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" TE.:<>: TE.Text \" the table \" TE.:<>: TE.ShowType t TE.:<>: TE.Text \" is not defined.\""
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n    TE.:$$: TE.Text \"\""
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"


genModuleText
  :: Text -- ^ module name
  -> Text -- ^ schema name
  -> (Map NameNS TypDef
    , Map (NameNS,Text) FldDef
    , Map NameNS (TabDef, [NameNS], [NameNS])
    , Map NameNS RelDef)
  -> Text
genModuleText :: Text
-> Text
-> (Map NameNS TypDef, Map (NameNS, Text) FldDef,
    Map NameNS (TabDef, [NameNS], [NameNS]), Map NameNS RelDef)
-> Text
genModuleText Text
moduleName Text
schName (Map NameNS TypDef
mtyp, Map (NameNS, Text) FldDef
mfld, Map NameNS (TabDef, [NameNS], [NameNS])
mtab, Map NameNS RelDef
mrel)
  =  Text
"{- HLINT ignore -}\n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"{-# LANGUAGE FlexibleContexts #-}\n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"{-# LANGUAGE TypeFamilies #-}\n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"{-# LANGUAGE UndecidableInstances #-}\n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}\n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"{-# OPTIONS_GHC -fno-warn-unused-imports #-}\n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"{-# OPTIONS_GHC -freduction-depth=300 #-}\n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"module " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
moduleName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where\n\n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-- This file is generated and can't be edited.\n\n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"import Control.DeepSeq\n" -- for PGEnum if exist
#ifdef MK_HASHABLE
  <> "import Data.Hashable\n" -- for PGEnum if exist
#endif
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"import GHC.Generics\n" -- for PGEnum if exists
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"import GHC.TypeError qualified as TE\n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"import GHC.TypeLits qualified as TL\n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"import PgSchema.Import\n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"data " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
schName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ((NameNS -> TypDef -> Text) -> (NameNS, TypDef) -> Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Text -> NameNS -> TypDef -> Text
textTypDef Text
schName) ((NameNS, TypDef) -> Text) -> [(NameNS, TypDef)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map NameNS TypDef -> [(NameNS, TypDef)]
forall k a. Map k a -> [(k, a)]
M.toList Map NameNS TypDef
mtyp)
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ((\(NameNS
tab,(TabDef
td,[NameNS]
_,[NameNS]
_)) -> Text -> NameNS -> TabDef -> Text
textTabDef Text
schName NameNS
tab TabDef
td) ((NameNS, (TabDef, [NameNS], [NameNS])) -> Text)
-> [(NameNS, (TabDef, [NameNS], [NameNS]))] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map NameNS (TabDef, [NameNS], [NameNS])
-> [(NameNS, (TabDef, [NameNS], [NameNS]))]
forall k a. Map k a -> [(k, a)]
M.toList Map NameNS (TabDef, [NameNS], [NameNS])
mtab)
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([ Text -> NameNS -> RelDef -> Text
textRelDef Text
schName NameNS
relName RelDef
rel | (NameNS
relName, RelDef
rel) <- Map NameNS RelDef -> [(NameNS, RelDef)]
forall k a. Map k a -> [(k, a)]
M.toList Map NameNS RelDef
mrel ])
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ((\(NameNS
tab,(TabDef
_,[NameNS]
froms,[NameNS]
tos)) -> Text -> NameNS -> [NameNS] -> [NameNS] -> Text
textTabRel Text
schName NameNS
tab [NameNS]
froms [NameNS]
tos)
    ((NameNS, (TabDef, [NameNS], [NameNS])) -> Text)
-> [(NameNS, (TabDef, [NameNS], [NameNS]))] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map NameNS (TabDef, [NameNS], [NameNS])
-> [(NameNS, (TabDef, [NameNS], [NameNS]))]
forall k a. Map k a -> [(k, a)]
M.toList Map NameNS (TabDef, [NameNS], [NameNS])
mtab)
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
-> (Map (NameNS, Text) FldDef,
    Map NameNS (TabDef, [NameNS], [NameNS]), Map NameNS RelDef)
-> Text
textClosedFieldInfoTF Text
schName (Map (NameNS, Text) FldDef
mfld, Map NameNS (TabDef, [NameNS], [NameNS])
mtab, Map NameNS RelDef
mrel)
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"instance CSchema " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
schName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where\n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"  type TTabs " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
schName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> [NameNS] -> Text
forall a. ShowType a => Int -> Int -> a -> Text
showSplit Int
4 Int
70 (Map NameNS (TabDef, [NameNS], [NameNS]) -> [NameNS]
forall k a. Map k a -> [k]
keys Map NameNS (TabDef, [NameNS], [NameNS])
mtab) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"  type TTypes " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
schName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> [NameNS] -> Text
forall a. ShowType a => Int -> Int -> a -> Text
showSplit Int
4 Int
70 (Map NameNS TypDef -> [NameNS]
forall k a. Map k a -> [k]
keys Map NameNS TypDef
mtyp) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"

showSplit :: ShowType a => Int -> Int -> a -> Text
showSplit :: forall a. ShowType a => Int -> Int -> a -> Text
showSplit Int
shift Int
width = Text -> Int -> Int -> Text -> Text
showSplit' Text
"," Int
shift Int
width (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. ShowType a => a -> Text
showType

showSplit' :: Text -> Int -> Int -> Text -> Text
showSplit' :: Text -> Int -> Int -> Text -> Text
showSplit' Text
delim Int
shift Int
width
  = [Text] -> Text
T.unlines ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall {a}. (a -> a) -> [a] -> [a]
mapTail ((Int -> Text -> Text
T.replicate Int
shift Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
delim Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>))
  ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> Text) -> [[Text]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
L.map (Text -> [Text] -> Text
T.intercalate Text
delim) ([[Text]] -> [Text]) -> (Text -> [[Text]]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[Text]], Int) -> [[Text]]
forall a b. (a, b) -> a
fst (([[Text]], Int) -> [[Text]])
-> (Text -> ([[Text]], Int)) -> Text -> [[Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ([[Text]], Int)
mkLines
  where
    mapTail :: (a -> a) -> [a] -> [a]
mapTail a -> a
_ []     = []
    mapTail a -> a
f (a
x:[a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
L.map a -> a
f [a]
xs
    mkLines :: Text -> ([[Text]], Int)
mkLines = (Text -> ([[Text]], Int) -> ([[Text]], Int))
-> ([[Text]], Int) -> [Text] -> ([[Text]], Int)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
L.foldr Text -> ([[Text]], Int) -> ([[Text]], Int)
step ([],Int
0)([Text] -> ([[Text]], Int))
-> (Text -> [Text]) -> Text -> ([[Text]], Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
delim
      where
        step :: Text -> ([[Text]], Int) -> ([[Text]], Int)
step Text
t ([[Text]]
xs,Int
len)
          | Int
tlen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
width = ([Text
t] [Text] -> [[Text]] -> [[Text]]
forall a. a -> [a] -> [a]
: [[Text]]
xs, Int
tlen)
          | Bool
otherwise = case [[Text]]
xs of
            []     -> ([[Text
t]], Int
tlen)
            [Text]
z : [[Text]]
zs -> ((Text
tText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
z)[Text] -> [[Text]] -> [[Text]]
forall a. a -> [a] -> [a]
:[[Text]]
zs, Int
tlen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len)
          where
            tlen :: Int
tlen = Text -> Int
T.length Text
t