{-# LANGUAGE OverloadedRecordDot #-}
module PgSchema.DML.InsertJSON
  ( insertJSON, insertJSON_, upsertJSON, upsertJSON_
  , insertJSONText, insertJSONText_ ) where

import Control.Monad
import Control.Monad.RWS
import Data.Aeson as A
import Data.ByteString.Lazy.Char8 qualified as BSL
import Data.Bifunctor
import Data.Foldable as F
import Data.Function
import Data.Functor
import Data.List as L
import Data.Map as M hiding (mapMaybe)
import Data.Maybe
import Data.Text as T hiding (any)
import Data.Traversable
import PgSchema.Ann
import PgSchema.DML.Insert.Types
import Database.PostgreSQL.Simple
import PgSchema.Schema
import PgSchema.Types
import Data.String
import GHC.Int
import PgSchema.Utils.Internal
import Prelude as P


-- | Insert records into a table and its children using JSON data internally.
--
-- Like 'upsertJSON', but requires all mandatory columns at every node (insert-only constraint).

insertJSON
  :: forall ann -> forall r r'. InsertTreeReturning ann r r'
  => Connection -> [r] -> IO ([r'], Text)
insertJSON :: forall (ann :: Ann) ->
forall r r'.
InsertTreeReturning ann r r' =>
Connection -> [r] -> IO ([r'], Text)
insertJSON ann @r @r' = forall (ann :: Ann) ->
forall r r'.
(TreeSch ann, TreeIn ann r, TreeOut ann r') =>
Connection -> [r] -> IO ([r'], Text)
forall r r'.
(CSchema (AnnSch ann), TreeIn ann r, TreeOut ann r') =>
Connection -> [r] -> IO ([r'], Text)
insertJSONImpl ann @r @r'

-- | Like 'insertJSON', but does not return rows.
--
insertJSON_
  :: forall ann -> forall r. InsertTreeNonReturning ann r
  => Connection -> [r] -> IO Text
insertJSON_ :: forall (ann :: Ann) ->
forall r.
InsertTreeNonReturning ann r =>
Connection -> [r] -> IO Text
insertJSON_ ann @r = forall (ann :: Ann) ->
forall r.
(TreeSch ann, TreeIn ann r) =>
Connection -> [r] -> IO Text
forall r.
(CSchema (AnnSch ann), TreeIn ann r) =>
Connection -> [r] -> IO Text
insertJSONImpl_ ann @r

-- | Upsert a forest of rows into the root table and its /child/ tables in one
-- round-trip, using JSON inside PostgreSQL (same pipeline as 'insertJSON').
--
-- __Input shape (@r@):__ a record tree that may contain the root table’s columns
-- and nested /child/ branches (one-to-many from the root downward). There are no
-- nested /parent/ branches: parent keys are implied by the tree you send, not by
-- embedding parent rows inside children.
--
-- __Output shape (@r'@):__ a record tree whose graph of nested tables is a
-- /subgraph/ of the input: the same tables can appear, but you choose which
-- columns (and which levels) appear in the result—whatever is available through
-- the generated @RETURNING@/result projection. Field sets may differ from @r@;
-- relation structure cannot grow beyond what you sent in.
--
-- __What to supply at each node:__ at every level, each row must either include
-- all mandatory columns (for columns that are mandatory in the schema /sense of
-- this API/) or, alternatively, enough primary-key columns to identify an existing
-- row. Foreign-key columns that are filled in by the parent level (for example
-- after an auto-generated id on insert) do /not/ need to be present on the child
-- payload.
--
-- __Insert vs update vs upsert per row:__ the engine picks one of @INSERT@,
-- @UPDATE@, or @UPSERT@ from the keys and mandatory fields you provide:
--
-- * all mandatory fields present and /no/ primary key  →  @INSERT@
-- * primary key present, not all mandatory fields      →  @UPDATE@
-- * primary key present /and/ all mandatory fields    →  @UPSERT@
--
-- 'insertJSON' is the same execution path but adds a stricter type-level
-- constraint: /every/ mandatory field must be present (pure inserts). 'upsertJSON'
-- relaxes that so updates and upserts are expressible as in the rules above.
upsertJSON
  :: forall ann -> forall r r'. UpsertTreeReturning ann r r'
  => Connection -> [r] -> IO ([r'], Text)
upsertJSON :: forall (ann :: Ann) ->
forall r r'.
UpsertTreeReturning ann r r' =>
Connection -> [r] -> IO ([r'], Text)
upsertJSON ann @r @r' = forall (ann :: Ann) ->
forall r r'.
(TreeSch ann, TreeIn ann r, TreeOut ann r') =>
Connection -> [r] -> IO ([r'], Text)
forall r r'.
(CSchema (AnnSch ann), TreeIn ann r, TreeOut ann r') =>
Connection -> [r] -> IO ([r'], Text)
insertJSONImpl ann @r @r'

-- | Like 'upsertJSON', but does not return rows.
--
upsertJSON_
  :: forall ann -> forall r. UpsertTreeNonReturning ann r
  => Connection -> [r] -> IO Text
upsertJSON_ :: forall (ann :: Ann) ->
forall r.
UpsertTreeNonReturning ann r =>
Connection -> [r] -> IO Text
upsertJSON_ ann @r = forall (ann :: Ann) ->
forall r.
(TreeSch ann, TreeIn ann r) =>
Connection -> [r] -> IO Text
forall r.
(CSchema (AnnSch ann), TreeIn ann r) =>
Connection -> [r] -> IO Text
insertJSONImpl_ ann @r

insertJSONImpl
  :: forall ann -> forall r r'. (TreeSch ann, TreeIn ann r, TreeOut ann r')
  => Connection -> [r] -> IO ([r'], Text)
insertJSONImpl :: forall (ann :: Ann) ->
forall r r'.
(TreeSch ann, TreeIn ann r, TreeOut ann r') =>
Connection -> [r] -> IO ([r'], Text)
insertJSONImpl ann @r @r' Connection
conn [r]
rs = Connection -> IO ([r'], Text) -> IO ([r'], Text)
forall a. Connection -> IO a -> IO a
withTransactionIfNot Connection
conn do
  let sql' :: String
sql' = Text -> String
T.unpack Text
sql in String -> IO () -> IO ()
forall a. String -> a -> a
trace' String
sql' (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO Int64
execute_ Connection
conn (Query -> IO Int64) -> Query -> IO Int64
forall a b. (a -> b) -> a -> b
$ String -> Query
forall a. IsString a => String -> a
fromString String
sql'
  [Only res] <- let q :: Query
q = Query
"select pg_temp.__ins(?)" in
    Query -> IO [Only [PgTag ann r']] -> IO [Only [PgTag ann r']]
forall a b. Show a => a -> b -> b
traceShow' Query
q
      (IO [Only [PgTag ann r']] -> IO [Only [PgTag ann r']])
-> IO [Only [PgTag ann r']] -> IO [Only [PgTag ann r']]
forall a b. (a -> b) -> a -> b
$ String -> IO [Only [PgTag ann r']] -> IO [Only [PgTag ann r']]
forall a. String -> a -> a
trace' (ByteString -> String
BSL.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ [PgTag ann r] -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (forall {k} (s :: k) t. t -> PgTag s t
forall (s :: Ann) t. t -> PgTag s t
PgTag @ann @r (r -> PgTag ann r) -> [r] -> [PgTag ann r]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [r]
rs))
      (IO [Only [PgTag ann r']] -> IO [Only [PgTag ann r']])
-> IO [Only [PgTag ann r']] -> IO [Only [PgTag ann r']]
forall a b. (a -> b) -> a -> b
$ Connection
-> Query -> Only [PgTag ann r] -> IO [Only [PgTag ann r']]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
q (Only [PgTag ann r] -> IO [Only [PgTag ann r']])
-> Only [PgTag ann r] -> IO [Only [PgTag ann r']]
forall a b. (a -> b) -> a -> b
$ [PgTag ann r] -> Only [PgTag ann r]
forall a. a -> Only a
Only ([PgTag ann r] -> Only [PgTag ann r])
-> [PgTag ann r] -> Only [PgTag ann r]
forall a b. (a -> b) -> a -> b
$ forall {k} (s :: k) t. t -> PgTag s t
forall (s :: Ann) t. t -> PgTag s t
PgTag @ann @r (r -> PgTag ann r) -> [r] -> [PgTag ann r]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [r]
rs
  void $ execute_ conn "drop function pg_temp.__ins"
  pure (unPgTag @ann @r' <$> res, sql)
  where
    sql :: Text
sql = forall (ann :: Ann) ->
forall r r'.
(TreeSch ann, CRecInfo ann r, CRecInfo ann r', IsString Text,
 Monoid Text, Ord Text) =>
Text
forall s.
forall (ann :: Ann) ->
forall r r'.
(TreeSch ann, CRecInfo ann r, CRecInfo ann r', IsString s,
 Monoid s, Ord s) =>
s
forall r r'.
(TreeSch ann, CRecInfo ann r, CRecInfo ann r', IsString Text,
 Monoid Text, Ord Text) =>
Text
insertJSONText ann @r @r'

withTransactionIfNot :: Connection -> IO a -> IO a
withTransactionIfNot :: forall a. Connection -> IO a -> IO a
withTransactionIfNot Connection
conn IO a
act = do
  isInTrans <- (Only (Maybe Int64) -> Bool) -> [Only (Maybe Int64)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Maybe a -> Bool
isJust @Int64 (Maybe Int64 -> Bool)
-> (Only (Maybe Int64) -> Maybe Int64)
-> Only (Maybe Int64)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only (Maybe Int64) -> Maybe Int64
forall a. Only a -> a
fromOnly)
    ([Only (Maybe Int64)] -> Bool)
-> IO [Only (Maybe Int64)] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Query -> IO [Only (Maybe Int64)]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
"SELECT txid_current_if_assigned()"
  (if isInTrans then id else withTransaction conn) act

insertJSONImpl_
  :: forall ann -> forall r. (TreeSch ann, TreeIn ann r)
  => Connection -> [r] -> IO Text
insertJSONImpl_ :: forall (ann :: Ann) ->
forall r.
(TreeSch ann, TreeIn ann r) =>
Connection -> [r] -> IO Text
insertJSONImpl_ ann @r Connection
conn [r]
rs = Connection -> IO Text -> IO Text
forall a. Connection -> IO a -> IO a
withTransactionIfNot Connection
conn do
  IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO Int64 -> IO Int64
forall a. String -> a -> a
trace' (Text -> String
T.unpack Text
sql) (IO Int64 -> IO Int64) -> IO Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO Int64
execute_ Connection
conn (Query -> IO Int64) -> Query -> IO Int64
forall a b. (a -> b) -> a -> b
$ String -> Query
forall a. IsString a => String -> a
fromString (String -> Query) -> String -> Query
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
sql
  IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> Only [PgTag ann r] -> IO Int64
forall q. ToRow q => Connection -> Query -> q -> IO Int64
execute Connection
conn Query
"call pg_temp.__ins(?)" (Only [PgTag ann r] -> IO Int64) -> Only [PgTag ann r] -> IO Int64
forall a b. (a -> b) -> a -> b
$ [PgTag ann r] -> Only [PgTag ann r]
forall a. a -> Only a
Only ([PgTag ann r] -> Only [PgTag ann r])
-> [PgTag ann r] -> Only [PgTag ann r]
forall a b. (a -> b) -> a -> b
$ forall {k} (s :: k) t. t -> PgTag s t
forall (s :: Ann) t. t -> PgTag s t
PgTag @ann @r (r -> PgTag ann r) -> [r] -> [PgTag ann r]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [r]
rs
  Text
sql Text -> IO Int64 -> IO Text
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Connection -> Query -> IO Int64
execute_ Connection
conn Query
"drop procedure pg_temp.__ins"
  where
    sql :: Text
sql = forall (ann :: Ann) ->
forall r s.
(IsString s, Monoid s, Ord s, TreeSch ann, CRecInfo ann r) =>
s
forall r s.
(IsString s, Monoid s, Ord s, TreeSch ann, CRecInfo ann r) =>
s
insertJSONText_ ann @r

insertJSONText_ :: forall ann -> forall r s.
  (IsString s, Monoid s, Ord s, TreeSch ann, CRecInfo ann r) => s
insertJSONText_ :: forall (ann :: Ann) ->
forall r s.
(IsString s, Monoid s, Ord s, TreeSch ann, CRecInfo ann r) =>
s
insertJSONText_ ann @r = Map NameNS TypDef
-> Map NameNS TabInfo -> RecordInfo Text -> [FieldInfo Text] -> s
forall s.
(IsString s, Monoid s, Ord s) =>
Map NameNS TypDef
-> Map NameNS TabInfo -> RecordInfo Text -> [FieldInfo Text] -> s
insertJSONText' (forall sch. CSchema sch => Map NameNS TypDef
forall {k} (sch :: k). CSchema sch => Map NameNS TypDef
typDefMap @(AnnSch ann)) (forall sch. CSchema sch => Map NameNS TabInfo
forall {k} (sch :: k). CSchema sch => Map NameNS TabInfo
tabInfoMap @(AnnSch ann))
  (forall (ann :: Ann) r. CRecInfo ann r => RecordInfo Text
getRecordInfo @ann @r) []

insertJSONText :: forall ann -> forall r r'.
  ( TreeSch ann, CRecInfo ann r, CRecInfo ann r'
  , IsString s, Monoid s, Ord s ) => s
insertJSONText :: forall s.
forall (ann :: Ann) ->
forall r r'.
(TreeSch ann, CRecInfo ann r, CRecInfo ann r', IsString s,
 Monoid s, Ord s) =>
s
insertJSONText ann @r @r' =
  Map NameNS TypDef
-> Map NameNS TabInfo -> RecordInfo Text -> [FieldInfo Text] -> s
forall s.
(IsString s, Monoid s, Ord s) =>
Map NameNS TypDef
-> Map NameNS TabInfo -> RecordInfo Text -> [FieldInfo Text] -> s
insertJSONText' (forall sch. CSchema sch => Map NameNS TypDef
forall {k} (sch :: k). CSchema sch => Map NameNS TypDef
typDefMap @(AnnSch ann)) (forall sch. CSchema sch => Map NameNS TabInfo
forall {k} (sch :: k). CSchema sch => Map NameNS TabInfo
tabInfoMap @(AnnSch ann))
    (forall (ann :: Ann) r. CRecInfo ann r => RecordInfo Text
getRecordInfo @ann @r) (forall (ann :: Ann) r. CRecInfo ann r => RecordInfo Text
getRecordInfo @ann @r').fields

insertJSONText'
  :: forall s. (IsString s, Monoid s, Ord s)
  => M.Map NameNS TypDef -> M.Map NameNS TabInfo -> RecordInfo Text -> [FieldInfo Text] -> s
insertJSONText' :: forall s.
(IsString s, Monoid s, Ord s) =>
Map NameNS TypDef
-> Map NameNS TabInfo -> RecordInfo Text -> [FieldInfo Text] -> s
insertJSONText' Map NameNS TypDef
mapTypes Map NameNS TabInfo
mapTabs RecordInfo Text
ir [FieldInfo Text]
qfs = [s] -> s
forall a. (Monoid a, IsString a) => [a] -> a
unlines'
  [ s -> (s -> s) -> Maybe s -> s
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    s
"create or replace procedure pg_temp.__ins(data_0 jsonb) as $$"
    (s -> s -> s
forall a b. a -> b -> a
const s
"create or replace function pg_temp.__ins(data_0 jsonb) returns jsonb as $$")
    Maybe s
mbRes
  , s
"declare"
  , [s] -> s
forall a. (Monoid a, IsString a) => [a] -> a
unlines' ([s] -> s) -> [s] -> s
forall a b. (a -> b) -> a -> b
$ (s
"  " s -> s -> s
forall a. Semigroup a => a -> a -> a
<>) (s -> s) -> [s] -> [s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [s]
decl
  , s
"begin"
  , [s] -> s
forall a. (Monoid a, IsString a) => [a] -> a
unlines' [s]
body
  , s -> (s -> s) -> Maybe s -> s
forall b a. b -> (a -> b) -> Maybe a -> b
maybe s
"" (\s
r ->s
"  return to_jsonb(" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
r s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
");") Maybe s
mbRes
  , s
"end; "
  , s
"$$ language plpgsql;" ]
  where
    (Maybe s
mbRes, ([s]
decl, [s]
body)) =
      RWS (s, Int) ([s], [s]) Int (Maybe s)
-> (s, Int) -> Int -> (Maybe s, ([s], [s]))
forall r w s a. RWS r w s a -> r -> s -> (a, w)
evalRWS (Map NameNS TypDef
-> Map NameNS TabInfo
-> RecordInfo Text
-> [FieldInfo Text]
-> [s]
-> [s]
-> RWS (s, Int) ([s], [s]) Int (Maybe s)
forall s.
(IsString s, Monoid s, Ord s) =>
Map NameNS TypDef
-> Map NameNS TabInfo
-> RecordInfo Text
-> [FieldInfo Text]
-> [s]
-> [s]
-> MonadInsert s (Maybe s)
insertJSONTextM Map NameNS TypDef
mapTypes Map NameNS TabInfo
mapTabs RecordInfo Text
ir [FieldInfo Text]
qfs [] []) (s
"  ",Int
0) Int
0

type MonadInsert s = RWS (s, Int) ([s],[s]) Int
-- R: (leading spaces to format code, number of table in tree)
-- W: (lines of declarations, lines of function body)
-- S: maximum number of table in tree "in use"

data OP = INS | UPD | UPS deriving (OP -> OP -> Bool
(OP -> OP -> Bool) -> (OP -> OP -> Bool) -> Eq OP
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OP -> OP -> Bool
== :: OP -> OP -> Bool
$c/= :: OP -> OP -> Bool
/= :: OP -> OP -> Bool
Eq, Int -> OP -> ShowS
[OP] -> ShowS
OP -> String
(Int -> OP -> ShowS)
-> (OP -> String) -> ([OP] -> ShowS) -> Show OP
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OP -> ShowS
showsPrec :: Int -> OP -> ShowS
$cshow :: OP -> String
show :: OP -> String
$cshowList :: [OP] -> ShowS
showList :: [OP] -> ShowS
Show)

data Field v = Field
  { forall v. Field v -> Text
jsonName :: Text
  , forall v. Field v -> Text
dbName :: Text
  , forall v. Field v -> v
info :: v }
  deriving (Field v -> Field v -> Bool
(Field v -> Field v -> Bool)
-> (Field v -> Field v -> Bool) -> Eq (Field v)
forall v. Eq v => Field v -> Field v -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall v. Eq v => Field v -> Field v -> Bool
== :: Field v -> Field v -> Bool
$c/= :: forall v. Eq v => Field v -> Field v -> Bool
/= :: Field v -> Field v -> Bool
Eq, Int -> Field v -> ShowS
[Field v] -> ShowS
Field v -> String
(Int -> Field v -> ShowS)
-> (Field v -> String) -> ([Field v] -> ShowS) -> Show (Field v)
forall v. Show v => Int -> Field v -> ShowS
forall v. Show v => [Field v] -> ShowS
forall v. Show v => Field v -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall v. Show v => Int -> Field v -> ShowS
showsPrec :: Int -> Field v -> ShowS
$cshow :: forall v. Show v => Field v -> String
show :: Field v -> String
$cshowList :: forall v. Show v => [Field v] -> ShowS
showList :: [Field v] -> ShowS
Show)

insertJSONTextM
  :: forall s. (IsString s, Monoid s, Ord s)
  => M.Map NameNS TypDef -> M.Map NameNS TabInfo -> RecordInfo Text
  -> [FieldInfo Text] -> [s] -> [s] -> MonadInsert s (Maybe s)
insertJSONTextM :: forall s.
(IsString s, Monoid s, Ord s) =>
Map NameNS TypDef
-> Map NameNS TabInfo
-> RecordInfo Text
-> [FieldInfo Text]
-> [s]
-> [s]
-> MonadInsert s (Maybe s)
insertJSONTextM Map NameNS TypDef
mapTypes Map NameNS TabInfo
mapTabs RecordInfo Text
ri [FieldInfo Text]
qfs [s]
fromFields [s]
toVars = do
  (spaces, n) <- RWST (s, Int) ([s], [s]) Int Identity (s, Int)
forall r (m :: * -> *). MonadReader r m => m r
ask
  let
    sn = Int -> s
forall b a. (IsString b, Show a) => a -> b
show' Int
n
    dataN = s
"data_" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
sn
    rowN  = s
"row_" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
sn
    mbArrN = (s
"arr_" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
sn) s -> Maybe () -> Maybe s
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [FieldInfo Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
P.null [FieldInfo Text]
qfs)
    decs = (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then [s] -> [s]
forall a. a -> a
P.id else (s
dataN s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
" jsonb;" s -> [s] -> [s]
forall a. a -> [a] -> [a]
:))
      [s
rowN s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
" record;"]
      [s] -> [s] -> [s]
forall a. Semigroup a => a -> a -> a
<> (s -> [s]) -> Maybe s -> [s]
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (s -> [s]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s -> [s]) -> (s -> s) -> s -> [s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
" jsonb[];")) Maybe s
mbArrN [s] -> [s] -> [s]
forall a. Semigroup a => a -> a -> a
<> [s]
qretDecls
    qretDecls = [(s, s)]
qretPairs [(s, s)] -> ((s, s) -> s) -> [s]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(s
fld, s
typ) -> s
fld s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
sn s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
" " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
typ s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
"; "
    initArray = (s -> [s]) -> Maybe s -> [s]
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (s -> [s]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s -> [s]) -> (s -> s) -> s -> [s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
":= '{}';")) Maybe s
mbArrN
    startLoop =
      [s
"for " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
rowN s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
" in select * from jsonb_array_elements("
      s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
dataN s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
")", s
"loop"]
    (ins, op) = case mbKeyMand of
      Just ([s]
pk, [s]
mflds)
        | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [s] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
P.null ([s] -> Bool) -> [s] -> Bool
forall a b. (a -> b) -> a -> b
$ [s]
mflds [s] -> [s] -> [s]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ ([s]
fromFields [s] -> [s] -> [s]
forall a. Semigroup a => a -> a -> a
<> ((s, s) -> s
forall a b. (a, b) -> a
fst ((s, s) -> s) -> [(s, s)] -> [s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(s, s)]
plains)) ->
          ([s] -> [s]
addSemiColon ([s]
upd0 [s] -> [s] -> [s]
forall a. Semigroup a => a -> a -> a
<> [s]
rets), OP
UPD)
        | [s] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
P.null ([s] -> Bool) -> [s] -> Bool
forall a b. (a -> b) -> a -> b
$ [s]
pk [s] -> [s] -> [s]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ ([s]
fromFields [s] -> [s] -> [s]
forall a. Semigroup a => a -> a -> a
<> ((s, s) -> s
forall a b. (a, b) -> a
fst ((s, s) -> s) -> [(s, s)] -> [s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(s, s)]
plainsPK)) -> ([s] -> [s]
ups0 [s]
pk, OP
UPS)
      Maybe ([s], [s])
_ -> ([s] -> [s]
addSemiColon ([s]
ins0 [s] -> [s] -> [s]
forall a. Semigroup a => a -> a -> a
<> [s]
rets), OP
INS)
      where
        srcFlds = [s]
fromFields [s] -> [s] -> [s]
forall a. Semigroup a => a -> a -> a
<> ((s, s) -> s
forall a b. (a, b) -> a
fst ((s, s) -> s) -> [(s, s)] -> [s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(s, s)]
plains)
        srcVars = [s]
toVars [s] -> [s] -> [s]
forall a. Semigroup a => a -> a -> a
<> (Field FldDef -> s
jsonFld (Field FldDef -> s) -> [Field FldDef] -> [s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Field FldDef]
iplains)
        srcMap = [(s, s)] -> Map s s
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(s, s)] -> Map s s) -> [(s, s)] -> Map s s
forall a b. (a -> b) -> a -> b
$ [s] -> [s] -> [(s, s)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [s]
srcFlds [s]
srcVars
        mbSetVars
          | [s] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
P.null ([s]
qretFlds [s] -> [s] -> [s]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [s]
srcFlds) = [s] -> Maybe [s]
forall a. a -> Maybe a
Just
            ([s] -> Maybe [s]) -> [s] -> Maybe [s]
forall a b. (a -> b) -> a -> b
$ [Maybe s] -> [s]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe s] -> [s]) -> [Maybe s] -> [s]
forall a b. (a -> b) -> a -> b
$ (s -> s -> Maybe s) -> [s] -> [s] -> [Maybe s]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
P.zipWith (\s
fld s
var ->
              (\s
srcVar -> s
var s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
" := " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
srcVar s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
";")
              (s -> s) -> Maybe s -> Maybe s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map s s
srcMap Map s s -> s -> Maybe s
forall k a. Ord k => Map k a -> k -> Maybe a
M.!? s
fld) [s]
qretFlds [s]
qretVars
          | Bool
otherwise = Maybe [s]
forall a. Maybe a
Nothing
        ins0 =
          [ s
"  insert into " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
qualTabName s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
"(" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s -> [s] -> s
forall a. Monoid a => a -> [a] -> a
intercalate' s
", " [s]
srcFlds s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
")"
          , s
"    values (" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s -> [s] -> s
forall a. Monoid a => a -> [a] -> a
intercalate' s
", " [s]
srcVars s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
")"]
        sWhere = s
"where " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s -> [s] -> s
forall a. Monoid a => a -> [a] -> a
intercalate' s
" and "
            ( (s -> s -> s) -> [s] -> [s] -> [s]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
L.zipWith s -> s -> s
forall {a}. (Semigroup a, IsString a) => a -> a -> a
nameVal [s]
fromFields [s]
toVars [s] -> [s] -> [s]
forall a. Semigroup a => a -> a -> a
<> ((s -> s -> s) -> (s, s) -> s
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry s -> s -> s
forall {a}. (Semigroup a, IsString a) => a -> a -> a
nameVal ((s, s) -> s) -> [(s, s)] -> [s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(s, s)]
plainsPK))
        upd0 =
          [ s
"  update " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
qualTabName
          , s
"    set " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s -> [s] -> s
forall a. Monoid a => a -> [a] -> a
intercalate' s
", " ((s -> s -> s) -> (s, s) -> s
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry s -> s -> s
forall {a}. (Semigroup a, IsString a) => a -> a -> a
nameVal ((s, s) -> s) -> [(s, s)] -> [s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(s, s)]
plains)
          , s
"    " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
sWhere]
        ups0 [s]
pk
          | [(s, s)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [(s, s)]
plainsOthers = case Maybe [s]
mbSetVars of
            Just [] -> [s] -> [s]
addSemiColon [s]
ins0
            Just [s]
xs -> [s]
ins0 [s] -> [s] -> [s]
forall a. Semigroup a => a -> a -> a
<> [ s
"    on conflict do nothing;"]
              [s] -> [s] -> [s]
forall a. Semigroup a => a -> a -> a
<> [s
"  " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s -> [s] -> s
forall a. Monoid a => a -> [a] -> a
intercalate' s
" " [s]
xs]
            Maybe [s]
Nothing -> [s]
ins0 [s] -> [s] -> [s]
forall a. Semigroup a => a -> a -> a
<> [s] -> [s]
addSemiColon ([ s
"    on conflict do nothing"] [s] -> [s] -> [s]
forall a. Semigroup a => a -> a -> a
<> [s]
rets)
              [s] -> [s] -> [s]
forall a. Semigroup a => a -> a -> a
<> [s
"  if not found then"
                , s
"    select " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s -> [s] -> s
forall a. Monoid a => a -> [a] -> a
intercalate' s
", " [s]
qretFlds s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
" into " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s -> [s] -> s
forall a. Monoid a => a -> [a] -> a
intercalate' s
", " [s]
qretVars
                , s
"      from " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
qualTabName
                , s
"      " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
sWhere s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
";"
                , s
"  end if;"]
          | [s] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [s]
pk = [s] -> [s]
addSemiColon [s]
ins0 -- support for tables without PK
          | Bool
otherwise = [s] -> [s]
addSemiColon ([s] -> [s]) -> [s] -> [s]
forall a b. (a -> b) -> a -> b
$ [s]
ins0
            [s] -> [s] -> [s]
forall a. Semigroup a => a -> a -> a
<> [ s
"    on conflict (" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s -> [s] -> s
forall a. Monoid a => a -> [a] -> a
intercalate' s
", " [s]
pk s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
")"
              , s
"      do update set " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s -> [s] -> s
forall a. Monoid a => a -> [a] -> a
intercalate' s
", " ([(s, s)]
plainsOthers [(s, s)] -> ((s, s) -> s) -> [s]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>
                  \(s
name, s
_) -> s
name s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
" = " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
"EXCLUDED." s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
name) ]
            [s] -> [s] -> [s]
forall a. Semigroup a => a -> a -> a
<> [s]
rets
        qretVars = (s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
sn) (s -> s) -> [s] -> [s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [s]
qretFlds
        plains = [Field FldDef]
iplains [Field FldDef] -> (Field FldDef -> (s, s)) -> [(s, s)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Field FldDef
ip -> (Text -> s
forall t. IsString t => Text -> t
fromText Field FldDef
ip.dbName, Field FldDef -> s
jsonFld Field FldDef
ip)
        (plainsPK, plainsOthers) = L.partition ((`L.elem` foldMap fst mbKeyMand) . fst) plains
        jsonFld Field FldDef
ip = case Map NameNS TypDef
mapTypes Map NameNS TypDef -> NameNS -> Maybe TypDef
forall k a. Ord k => Map k a -> k -> Maybe a
M.!? Field FldDef
ip.info.fdType of
          Just (TypDef Text
"A" (Just NameNS
t) [Text]
_) ->
            s
"case when jsonb_typeof(" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
rowN s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
".value->'" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> Text -> s
forall t. IsString t => Text -> t
fromText Field FldDef
ip.jsonName s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
"') = 'array'"
            s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
" then (select coalesce(array_agg(__x)::" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> Text -> s
forall t. IsString t => Text -> t
fromText (NameNS -> Text
qualName NameNS
t) s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
"[], '{}')"
            s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
" from jsonb_array_elements_text(" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
rowN s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
".value->'" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> Text -> s
forall t. IsString t => Text -> t
fromText Field FldDef
ip.jsonName s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
"') __x) else null end"
          Maybe TypDef
_ ->
            s
"(" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
rowN s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
".value->>'" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> Text -> s
forall t. IsString t => Text -> t
fromText Field FldDef
ip.jsonName s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
"')::"
              s -> s -> s
forall a. Semigroup a => a -> a -> a
<> Text -> s
forall t. IsString t => Text -> t
fromText (NameNS -> Text
qualName Field FldDef
ip.info.fdType)
        rets
          | Bool
noRets = []
          | Bool
otherwise = [s
"    returning " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s -> [s] -> s
forall a. Monoid a => a -> [a] -> a
intercalate' s
", " [s]
qretFlds
            s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
" into " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s -> [s] -> s
forall a. Monoid a => a -> [a] -> a
intercalate' s
", " [s]
qretVars]
    endLoop = s
"end loop;"
    processChildren = do
      (spaces', _) <- RWST (s, Int) ([s], [s]) Int Identity (s, Int)
forall r (m :: * -> *). MonadReader r m => m r
ask
      (mapMaybe sequenceA -> arrs) <- for ichildren \(Field [Ref' Text]
child, RecordInfo Text
childRi) -> do
        (Int -> Int) -> RWST (s, Int) ([s], [s]) Int Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        n' <- RWST (s, Int) ([s], [s]) Int Identity Int
forall s (m :: * -> *). MonadState s m => m s
get
        tell (mempty, pure $ spaces' <> "data_" <> show' n' <> " := "
          <> rowN <> ".value->'" <> fromText child.jsonName <> "';")
        let
          qfs' = ((Field [Ref' Text], RecordInfo Text) -> [FieldInfo Text])
-> Maybe (Field [Ref' Text], RecordInfo Text) -> [FieldInfo Text]
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((.fields) (RecordInfo Text -> [FieldInfo Text])
-> ((Field [Ref' Text], RecordInfo Text) -> RecordInfo Text)
-> (Field [Ref' Text], RecordInfo Text)
-> [FieldInfo Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Field [Ref' Text], RecordInfo Text) -> RecordInfo Text
forall a b. (a, b) -> b
snd)
            (Maybe (Field [Ref' Text], RecordInfo Text) -> [FieldInfo Text])
-> Maybe (Field [Ref' Text], RecordInfo Text) -> [FieldInfo Text]
forall a b. (a -> b) -> a -> b
$ ((Field [Ref' Text], RecordInfo Text) -> Bool)
-> [(Field [Ref' Text], RecordInfo Text)]
-> Maybe (Field [Ref' Text], RecordInfo Text)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (\(Field [Ref' Text]
qc, RecordInfo Text
_) -> Field [Ref' Text]
qc.jsonName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Field [Ref' Text]
child.jsonName) [(Field [Ref' Text], RecordInfo Text)]
qchildren
        mbArr <- local (second $ const n') $ insertJSONTextM mapTypes mapTabs
          childRi qfs' (fromText . (.fromName) <$> child.info)
          ((<> sn) . fromText . (.toName) <$> child.info)
        pure (fromText child.jsonName, mbArr)
      let
        appendArray = (s -> [s]) -> Maybe s -> [s]
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\s
arrN -> s -> [s]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s -> [s]) -> s -> [s]
forall a b. (a -> b) -> a -> b
$ s
arrN s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
":= array_append("
          s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
arrN s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
", jsonb_build_object(" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
jsonFlds s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
"));") Maybe s
mbArrN
          where
            jsonFlds :: s
jsonFlds = s -> [s] -> s
forall a. Monoid a => a -> [a] -> a
intercalate' s
", "
              ([s] -> s) -> [s] -> s
forall a b. (a -> b) -> a -> b
$ ([Field FldDef]
qplains [Field FldDef] -> (Field FldDef -> s) -> [s]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Field FldDef
qp -> s
"'" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> Text -> s
forall t. IsString t => Text -> t
fromText Field FldDef
qp.jsonName
              s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
"', " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> Text -> s
forall t. IsString t => Text -> t
fromText Field FldDef
qp.dbName s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
sn)
              [s] -> [s] -> [s]
forall a. Semigroup a => a -> a -> a
<> ([(s, s)]
arrs [(s, s)] -> ((s, s) -> s) -> [s]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(s
jsonN, s
arr) -> s
"'" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
jsonN s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
"', to_jsonb(" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
arr s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
")")
      tell (mempty, fmap (spaces' <>) appendArray)
  tell (decs, fmap (spaces <>) $ initArray <> startLoop <> ins)
  case op of
    OP
UPD -> do
      ([s], [s]) -> RWST (s, Int) ([s], [s]) Int Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([s]
forall a. Monoid a => a
mempty, s -> [s]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s -> [s]) -> s -> [s]
forall a b. (a -> b) -> a -> b
$ s
spaces s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
"  if found then")
      ((s, Int) -> (s, Int))
-> RWST (s, Int) ([s], [s]) Int Identity ()
-> RWST (s, Int) ([s], [s]) Int Identity ()
forall a.
((s, Int) -> (s, Int))
-> RWST (s, Int) ([s], [s]) Int Identity a
-> RWST (s, Int) ([s], [s]) Int Identity a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((s -> s) -> (s, Int) -> (s, Int)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (s
"    " s -> s -> s
forall a. Semigroup a => a -> a -> a
<>)) RWST (s, Int) ([s], [s]) Int Identity ()
processChildren
      ([s], [s]) -> RWST (s, Int) ([s], [s]) Int Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([s]
forall a. Monoid a => a
mempty, s -> [s]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s -> [s]) -> s -> [s]
forall a b. (a -> b) -> a -> b
$ s
spaces s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
"  end if;")
    OP
_ -> ((s, Int) -> (s, Int))
-> RWST (s, Int) ([s], [s]) Int Identity ()
-> RWST (s, Int) ([s], [s]) Int Identity ()
forall a.
((s, Int) -> (s, Int))
-> RWST (s, Int) ([s], [s]) Int Identity a
-> RWST (s, Int) ([s], [s]) Int Identity a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((s -> s) -> (s, Int) -> (s, Int)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (s
"  " s -> s -> s
forall a. Semigroup a => a -> a -> a
<>)) RWST (s, Int) ([s], [s]) Int Identity ()
processChildren
  tell (mempty, pure $ spaces <> endLoop)
  pure mbArrN
  where
    splitFields :: [FieldInfo Text]
-> ([Field FldDef], [(Field [Ref' Text], RecordInfo Text)])
splitFields = (FieldInfo Text
 -> ([Field FldDef], [(Field [Ref' Text], RecordInfo Text)])
 -> ([Field FldDef], [(Field [Ref' Text], RecordInfo Text)]))
-> ([Field FldDef], [(Field [Ref' Text], RecordInfo Text)])
-> [FieldInfo Text]
-> ([Field FldDef], [(Field [Ref' Text], RecordInfo Text)])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
P.foldr (\FieldInfo Text
fi -> case FieldInfo Text
fi.fieldKind of
      (RFPlain FldDef
fd)  -> ([Field FldDef] -> [Field FldDef])
-> ([Field FldDef], [(Field [Ref' Text], RecordInfo Text)])
-> ([Field FldDef], [(Field [Ref' Text], RecordInfo Text)])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> Text -> FldDef -> Field FldDef
forall v. Text -> Text -> v -> Field v
Field FieldInfo Text
fi.fieldName FieldInfo Text
fi.fieldDbName FldDef
fd Field FldDef -> [Field FldDef] -> [Field FldDef]
forall a. a -> [a] -> [a]
:)
      (RFToHere RecordInfo Text
ri' [Ref' Text]
refs) -> ([(Field [Ref' Text], RecordInfo Text)]
 -> [(Field [Ref' Text], RecordInfo Text)])
-> ([Field FldDef], [(Field [Ref' Text], RecordInfo Text)])
-> ([Field FldDef], [(Field [Ref' Text], RecordInfo Text)])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Text -> Text -> [Ref' Text] -> Field [Ref' Text]
forall v. Text -> Text -> v -> Field v
Field FieldInfo Text
fi.fieldName FieldInfo Text
fi.fieldDbName [Ref' Text]
refs, RecordInfo Text
ri') (Field [Ref' Text], RecordInfo Text)
-> [(Field [Ref' Text], RecordInfo Text)]
-> [(Field [Ref' Text], RecordInfo Text)]
forall a. a -> [a] -> [a]
:)
      RecField' Text (RecordInfo Text)
_ -> ([Field FldDef], [(Field [Ref' Text], RecordInfo Text)])
-> ([Field FldDef], [(Field [Ref' Text], RecordInfo Text)])
forall a. a -> a
P.id) ([Field FldDef], [(Field [Ref' Text], RecordInfo Text)])
forall a. Monoid a => a
mempty
    ([Field FldDef]
iplains, [(Field [Ref' Text], RecordInfo Text)]
ichildren) = [FieldInfo Text]
-> ([Field FldDef], [(Field [Ref' Text], RecordInfo Text)])
splitFields RecordInfo Text
ri.fields
    ([Field FldDef]
qplains, [(Field [Ref' Text], RecordInfo Text)]
qchildren) = [FieldInfo Text]
-> ([Field FldDef], [(Field [Ref' Text], RecordInfo Text)])
splitFields [FieldInfo Text]
qfs
    mbKeyMand :: Maybe ([s], [s])
mbKeyMand = Map NameNS TabInfo
mapTabs Map NameNS TabInfo -> NameNS -> Maybe TabInfo
forall k a. Ord k => Map k a -> k -> Maybe a
M.!? RecordInfo Text
ri.tabName Maybe TabInfo -> (TabInfo -> ([s], [s])) -> Maybe ([s], [s])
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((,)
      ([s] -> [s] -> ([s], [s]))
-> (TabInfo -> [s]) -> TabInfo -> [s] -> ([s], [s])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> s) -> [Text] -> [s]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> s
forall t. IsString t => Text -> t
fromText ([Text] -> [s]) -> (TabInfo -> [Text]) -> TabInfo -> [s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.tiDef.tdKey)
      (TabInfo -> [s] -> ([s], [s]))
-> (TabInfo -> [s]) -> TabInfo -> ([s], [s])
forall a b. (TabInfo -> a -> b) -> (TabInfo -> a) -> TabInfo -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> s) -> [Text] -> [s]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> s
forall t. IsString t => Text -> t
fromText ([Text] -> [s]) -> (TabInfo -> [Text]) -> TabInfo -> [s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text FldDef -> [Text]
forall k a. Map k a -> [k]
M.keys
        (Map Text FldDef -> [Text])
-> (TabInfo -> Map Text FldDef) -> TabInfo -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FldDef -> Bool) -> Map Text FldDef -> Map Text FldDef
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (\FldDef
fd -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FldDef
fd.fdNullable Bool -> Bool -> Bool
|| FldDef
fd.fdHasDefault) (Map Text FldDef -> Map Text FldDef)
-> (TabInfo -> Map Text FldDef) -> TabInfo -> Map Text FldDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.tiFlds))
    qualTabName :: s
qualTabName = Text -> s
forall t. IsString t => Text -> t
fromText (NameNS -> Text
qualName RecordInfo Text
ri.tabName)
    qcFlds :: [(Text, Text)]
qcFlds = (Ref' Text -> (Text, Text)) -> [Ref' Text] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) (Text -> Text -> (Text, Text))
-> (Ref' Text -> Text) -> Ref' Text -> Text -> (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (.toName) (Ref' Text -> Text -> (Text, Text))
-> (Ref' Text -> Text) -> Ref' Text -> (Text, Text)
forall a b.
(Ref' Text -> a -> b) -> (Ref' Text -> a) -> Ref' Text -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NameNS -> Text
qualName (NameNS -> Text) -> (Ref' Text -> NameNS) -> Ref' Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.toDef.fdType))
      ([Ref' Text] -> [(Text, Text)]) -> [Ref' Text] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ (Ref' Text -> Ref' Text -> Bool) -> [Ref' Text] -> [Ref' Text]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Text -> Text -> Bool)
-> (Ref' Text -> Text) -> Ref' Text -> Ref' Text -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (.toName)) ([Ref' Text] -> [Ref' Text]) -> [Ref' Text] -> [Ref' Text]
forall a b. (a -> b) -> a -> b
$ [(Field [Ref' Text], RecordInfo Text)]
ichildren [(Field [Ref' Text], RecordInfo Text)]
-> ((Field [Ref' Text], RecordInfo Text) -> [Ref' Text])
-> [Ref' Text]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(Field [Ref' Text], RecordInfo Text)
x -> ((Field [Ref' Text], RecordInfo Text) -> Field [Ref' Text]
forall a b. (a, b) -> a
fst (Field [Ref' Text], RecordInfo Text)
x).info)
    qpFlds :: [(Text, Text)]
qpFlds = [Field FldDef]
qplains [Field FldDef] -> (Field FldDef -> (Text, Text)) -> [(Text, Text)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Field FldDef
p -> (Field FldDef
p.dbName, NameNS -> Text
qualName Field FldDef
p.info.fdType)
    qretPairs :: [(s, s)]
qretPairs = ((Text, Text) -> (s, s)) -> [(Text, Text)] -> [(s, s)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> s) -> (Text -> s) -> (Text, Text) -> (s, s)
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 Text -> s
forall t. IsString t => Text -> t
fromText Text -> s
forall t. IsString t => Text -> t
fromText)
      ([(Text, Text)] -> [(s, s)]) -> [(Text, Text)] -> [(s, s)]
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> (Text, Text) -> Bool)
-> [(Text, Text)] -> [(Text, Text)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Text -> Text -> Bool)
-> ((Text, Text) -> Text) -> (Text, Text) -> (Text, Text) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Text, Text) -> Text
forall a b. (a, b) -> a
fst) ([(Text, Text)] -> [(Text, Text)])
-> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ [(Text, Text)]
qcFlds [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. Semigroup a => a -> a -> a
<> [(Text, Text)]
qpFlds
    nameVal :: a -> a -> a
nameVal a
name a
val = a
name a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" = " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
val
    noRets :: Bool
noRets = [Field FldDef] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
P.null [Field FldDef]
qplains Bool -> Bool -> Bool
&& [(Field [Ref' Text], RecordInfo Text)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
P.null [(Field [Ref' Text], RecordInfo Text)]
ichildren
    qretFlds :: [s]
qretFlds = (s, s) -> s
forall a b. (a, b) -> a
fst ((s, s) -> s) -> [(s, s)] -> [s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(s, s)]
qretPairs
    addSemiColon :: [s] -> [s]
addSemiColon = \case
      [] -> []
      [s
x] -> [s
x s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
";"]
      (s
x:[s]
xs) -> s
x s -> [s] -> [s]
forall a. a -> [a] -> [a]
: [s] -> [s]
addSemiColon [s]
xs