pg-schema-0.7.1.0: test-gen/Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultilineStrings #-}
{-# LANGUAGE ImportQualifiedPost #-}

import Control.Exception (bracket)
import Data.Functor
import Data.ByteString.Char8 qualified as BS
import Database.PostgreSQL.Simple
import System.Environment
import PgSchema.Generation
import Prelude as P


main :: IO ()
main = do
  connStr <- maybe "dbname=schema_test" BS.pack <$> lookupEnv "PG_CONN"
  bracket (connectPostgreSQL connStr) close $ \conn -> do
    putStrLn "Setting up schema..."
    execute_ conn """
      CREATE EXTENSION IF NOT EXISTS citext SCHEMA public VERSION \"1.6\";
      CREATE EXTENSION IF NOT EXISTS \"uuid-ossp\" SCHEMA public VERSION \"1.1\";
      DROP SCHEMA IF EXISTS test_pgs CASCADE; 
      CREATE SCHEMA test_pgs;
      SET search_path TO test_pgs, public;
      CREATE TABLE base_converts 
        (cboolean boolean, cint4 int4, cfloat8 float8, cdate date        
        , ctime time, ctimestamp timestamp, ctimestamptz timestamptz, ctext text);
      create type color as enum ('red', 'green', 'blue');
      create table ext_converts 
        (ccitext citext, cbytea bytea, cjsonb jsonb, cjson json, cuuid uuid, ccolor color);
      create table base_arr_converts (cboolean boolean[], cint4 int4[]
        , cfloat8 float8[]
        , ctimestamptz timestamptz[] 
        , ctext text[]
        );
      create table ext_arr_converts 
        (ccitext citext[], cbytea bytea[], cjsonb jsonb[], cuuid uuid[], ccolor color[]);

      create table dim (
        id        serial primary key,
        name      text not null
      );

      -- Root of hierarchy; two FKs to dim for distinct roles (dim_a, dim_b).
      create table root (
        id         serial primary key,
        code       text not null,
        grp        integer not null,
        name       text not null,
        created_at timestamptz not null default now(),
        dim_a_id   integer,
        dim_b_id   integer,
        constraint root_code_grp_uq unique (code, grp),
        constraint root_dim_a_fk foreign key (dim_a_id) references dim (id) on delete restrict,
        constraint root_dim_b_fk foreign key (dim_b_id) references dim (id) on delete restrict
      );

      -- Simple child (single-column PK/FK).
      create table mid1 (
        id       serial primary key,
        root_id  integer not null,
        pos      integer not null,
        flag     boolean not null,
        sort_key integer not null,
        payload  text,
        constraint mid1_root_fk foreign key (root_id) references root (id) on delete cascade
      );

      -- Child with composite PK and single-column FK to root.
      create table mid2 (
        root_id   integer not null,
        seq       integer not null,
        kind      text not null,
        flag      boolean not null,
        priority  integer not null,
        payload   jsonb,
        constraint mid2_pk primary key (root_id, seq),
        constraint mid2_root_fk foreign key (root_id) references root (id) on delete cascade
      );

      -- Leaf with composite PK and composite FK to mid2.
      create table leaf (
        root_id    integer not null,
        seq        integer not null,
        leaf_no    integer not null,
        value      float4 not null,
        category   text,
        created_at timestamptz not null default now(),
        constraint leaf_pk primary key (root_id, seq, leaf_no),
        constraint leaf_mid2_fk foreign key (root_id, seq) references mid2 (root_id, seq) on delete cascade
      );

      -- Upsert by nullable unique key when table has no NOT NULL UK.
      create table nullable_uq_row (
        id     serial primary key,
        code   text not null,
        suffix text,
        name   text not null,
        note   text,
        constraint nullable_uq_row_code_suffix_uq unique (code, suffix)
      );

      -- Table for array types (nullable elements, no 2D arrays).
      create table arrays (
        id             serial primary key,
        root_id        integer,
        dates_nullable date[],
        jsons          jsonb[],
        constraint arrays_root_fk foreign key (root_id) references root (id) on delete cascade
      );
      """

    putStrLn "Running generator..."
    void $ updateSchemaFile False "test-pgs/Sch.hs" (Right connStr)
      "Sch" -- ^ haskell module name to generate
      "Sch" -- ^ name of generated haskell type for schema
      (GenNames ["test_pgs"] [] []) -- ^ name of schemas in database