From 554d94054116a4859ab587bbf58e5496335047ca Mon Sep 17 00:00:00 2001 From: Ollie Charles Date: Sat, 19 Jun 2021 16:44:11 +0100 Subject: [PATCH 1/2] Add schema-to-rel8 This executable takes a database connection string and a schema name, and prints out Haskell code to STDOUT that defines all `data` types along with corresponding `TableSchema`s. --- exe-rel8-import/Main.hs | 280 ++++++++++++++++++++++++++++++++++++++++ rel8.cabal | 23 ++++ 2 files changed, 303 insertions(+) create mode 100644 exe-rel8-import/Main.hs diff --git a/exe-rel8-import/Main.hs b/exe-rel8-import/Main.hs new file mode 100644 index 00000000..f190ad7f --- /dev/null +++ b/exe-rel8-import/Main.hs @@ -0,0 +1,280 @@ +{-# language ApplicativeDo #-} +{-# language BlockArguments #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DerivingStrategies #-} +{-# language DuplicateRecordFields #-} +{-# language DisambiguateRecordFields #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language LambdaCase #-} +{-# language NamedFieldPuns #-} +{-# language OverloadedStrings #-} +{-# language RecordWildCards #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneDeriving #-} +{-# language TypeFamilies #-} + +module Main ( main ) where + +import qualified Data.ByteString.Char8 as BS +import Options.Applicative ( Parser, strOption, long, info, execParser ) +import Data.ByteString ( ByteString ) +import Data.Int ( Int64 ) +import Data.Text ( Text, unpack ) +import GHC.Generics ( Generic ) +import Hasql.Connection +import Prelude hiding ( filter ) +import Rel8 hiding (Table) +import Text.Casing ( camel, pascal ) +import qualified Language.Haskell.Exts.Pretty as HS +import qualified Language.Haskell.Exts.Syntax as HS +import qualified Data.List.NonEmpty as NonEmpty + +data Relkind = RTable + deriving stock (Show) + deriving anyclass (DBEq) + +instance DBType Relkind where + typeInformation = parseTypeInformation parser printer typeInformation + where + parser = \case + "r" -> pure RTable + (x :: Text) -> Left $ "Unknown relkind: " ++ show x + + printer = \case + RTable -> "r" + +newtype Oid = Oid Int64 + deriving newtype (DBType, DBEq, Show) + +data PGClass f = PGClass + { oid :: Column f Oid + , relname :: Column f Text + , relkind :: Column f Relkind + , relnamespace :: Column f Oid + } + deriving stock (Generic) + deriving anyclass (Rel8able) + +deriving stock instance f ~ Result => Show (PGClass f) + +pgclass :: TableSchema (PGClass Name) +pgclass = TableSchema + { name = "pg_class" + , schema = Just "pg_catalog" + , columns = namesFromLabelsWith NonEmpty.last + } + +data PGAttribute f = PGAttribute + { attrelid :: Column f Oid + , attname :: Column f Text + , atttypid :: Column f Oid + , attnum :: Column f Int64 + } + deriving stock (Generic) + deriving anyclass (Rel8able) + +deriving stock instance f ~ Result => Show (PGAttribute f) + +pgattribute :: TableSchema (PGAttribute Name) +pgattribute = TableSchema + { name = "pg_attribute" + , schema = Just "pg_catalog" + , columns = namesFromLabelsWith NonEmpty.last + } + +data PGType f = PGType + { oid :: Column f Oid + , typname :: Column f Text + } + deriving stock (Generic) + deriving anyclass (Rel8able) + +deriving stock instance f ~ Result => Show (PGType f) + +pgtype :: TableSchema (PGType Name) +pgtype = TableSchema + { name = "pg_type" + , schema = Just "pg_catalog" + , columns = namesFromLabelsWith NonEmpty.last + } + +data PGNamespace f = PGNamespace + { oid :: Column f Oid + , nspname :: Column f Text + } + deriving stock (Generic) + deriving anyclass (Rel8able) + +deriving stock instance f ~ Result => Show (PGNamespace f) + +pgnamespace :: TableSchema (PGNamespace Name) +pgnamespace = TableSchema + { name = "pg_namespace" + , schema = Just "pg_catalog" + , columns = namesFromLabelsWith NonEmpty.last + } + +data Table f = Table + { name :: Column f Text + , columns :: HList f (Attribute f) + } + deriving stock (Generic) + deriving anyclass (Rel8able) + +deriving stock instance f ~ Result => Show (Table f) + +data Attribute f = Attribute + { attribute :: PGAttribute f + , typ :: PGType f + } + deriving stock (Generic) + deriving anyclass (Rel8able) + +deriving stock instance f ~ Result => Show (Attribute f) + + +data Arguments = Arguments + { connectionString :: ByteString + , schema :: Text + } + +parser :: Parser Arguments +parser = do + connectionString <- BS.pack <$> strOption (long "connection") + schema <- strOption (long "schema") + return Arguments{..} + +main :: IO () +main = do + Arguments{ connectionString, schema } <- execParser $ info parser mempty + + Right c <- acquire connectionString + tables <- select c do + table@PGClass{ oid = tableOid, relname, relnamespace } <- + each pgclass + >>= filter ((lit RTable ==.) . relkind) + + namespace <- + each pgnamespace + >>= filter (\PGNamespace{ oid = namespaceOid } -> relnamespace ==. namespaceOid) + >>= filter ((lit schema ==.) . nspname) + + columns <- many do + attribute@PGAttribute{ atttypid } <- + each pgattribute + >>= filter ((tableOid ==.) . attrelid) + >>= filter ((>. 0) . attnum) + + typ <- + each pgtype + >>= filter (\PGType{ oid = typoid } -> atttypid ==. typoid) + + return Attribute{ attribute, typ } + + return Table + { name = relname + , .. + } + + putStrLn $ HS.prettyPrint $ tablesToModule tables + + +tablesToModule :: [Table Result] -> HS.Module () +tablesToModule tables = HS.Module () Nothing pragmas imports allTableDecls + where + pragmas = [ deriveGeneric, deriveAnyClass, derivingStrategies, overloadedStrings ] + where + deriveGeneric = HS.LanguagePragma () $ pure $ HS.Ident () "DeriveGeneric" + deriveAnyClass = HS.LanguagePragma () $ pure $ HS.Ident () "DeriveAnyClass" + derivingStrategies = HS.LanguagePragma () $ pure $ HS.Ident () "DerivingStrategies" + overloadedStrings = HS.LanguagePragma () $ pure $ HS.Ident () "OverloadedStrings" + + imports = map mkImport [ "GHC.Generic", "Rel8" ] + where + mkImport name = HS.ImportDecl + { importAnn = () + , importModule = HS.ModuleName () name + , importQualified = False + , importSrc = False + , importSafe = False + , importPkg = Nothing + , importAs = Nothing + , importSpecs = Nothing + } + + allTableDecls = concatMap tableDecls tables + where + tableDecls Table{ name, columns } = rel8able:tableSchema + where + pascalName = HS.Ident () $ pascal $ unpack name + + rel8able = HS.DataDecl () (HS.DataType ()) Nothing declHead [constructor] [derivingGeneric, derivingRel8able] + where + declHead = HS.DHApp () tyName f + where + tyName = HS.DHead () pascalName + f = HS.UnkindedVar () (HS.Ident () "f") + + constructor = HS.QualConDecl () Nothing Nothing conDecl + where + conDecl = HS.RecDecl () pascalName $ map field columns + field Attribute{ attribute, typ } = HS.FieldDecl () [fieldName] $ columnF columnType + where + fieldName = HS.Ident () $ camel $ unpack $ attname attribute + columnType = HS.TyCon () $ HS.UnQual () $ HS.Ident () $ pascal $ unpack $ typname typ + columnF = HS.TyApp () (HS.TyApp () _Column f) + where + _Column = HS.TyCon () $ HS.UnQual () $ HS.Ident () "Column" + f = HS.TyVar () $ HS.Ident () "f" + + derivingGeneric = HS.Deriving () (Just (HS.DerivStock ())) [rule] + where + rule = HS.IRule () Nothing Nothing $ HS.IHCon () $ HS.UnQual () $ HS.Ident () "Generic" + + derivingRel8able = HS.Deriving () (Just (HS.DerivAnyclass ())) [rule] + where + rule = HS.IRule () Nothing Nothing $ HS.IHCon () $ HS.UnQual () $ HS.Ident () "Rel8able" + + tableSchema = [ typeSig, HS.FunBind () [match] ] + where + schemaName = HS.Ident () $ camel $ unpack name + + typeSig = HS.TypeSig () [schemaName] t + where + t = HS.TyApp () _TableSchema (HS.TyApp () (HS.TyCon () (HS.UnQual () pascalName)) _Name) + where + _TableSchema = HS.TyCon () $ HS.UnQual () $ HS.Ident () "TableSchema" + _Name = HS.TyCon () $ HS.UnQual () $ HS.Ident () "Name" + + match = HS.Match () schemaName [] rhs Nothing + where + rhs = HS.UnGuardedRhs () tableSchemaExp + where + tableSchemaExp = HS.RecConstr () _TableSchema [ nameField, schemaField, columnsField ] + where + _TableSchema = HS.UnQual () $ HS.Ident () "TableSchema" + + nameField = HS.FieldUpdate () (HS.UnQual () (HS.Ident () "name")) $ HS.Lit () $ HS.String () str str + where + str = unpack name + + schemaField = + HS.FieldUpdate () (HS.UnQual () (HS.Ident () "schema")) $ + HS.App () (HS.Con () (HS.UnQual () (HS.Ident () "Just"))) $ + HS.Lit () $ HS.String () str str + where + str = unpack name + + columnsField = HS.FieldUpdate () columnsName columnsRecord + where + columnsName = HS.UnQual () (HS.Ident () "columns") + columnsRecord = HS.RecConstr () (HS.UnQual () pascalName) $ map field columns + + field Attribute{ attribute, typ } = HS.FieldUpdate () (HS.UnQual () fieldName) columnName + where + fieldName = HS.Ident () $ camel $ unpack $ attname attribute + columnName = HS.Lit () $ HS.String () str str + where + str = unpack $ attname attribute + diff --git a/rel8.cabal b/rel8.cabal index 0d4f1fd0..6bbbcf78 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -208,3 +208,26 @@ test-suite tests -Wno-missing-import-lists -Wno-prepositive-qualified-module -Wno-deprecations -Wno-monomorphism-restriction -Wno-missing-local-signatures -Wno-implicit-prelude + + +executable schema-to-rel8 + build-depends: + base ^>= 4.14 || ^>=4.15 + , bytestring + , casing + , haskell-src-exts + , hasql + , optparse-applicative + , rel8 + , text + default-language: + Haskell2010 + ghc-options: + -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode + -Wno-missing-import-lists -Wno-prepositive-qualified-module + -Wno-monomorphism-restriction + -Wno-missing-local-signatures + hs-source-dirs: + exe-rel8-import + main-is: + Main.hs From a1573b969234e716ab964bbaf8a944bfd81c8306 Mon Sep 17 00:00:00 2001 From: Ollie Charles Date: Sat, 19 Jun 2021 16:58:15 +0100 Subject: [PATCH 2/2] Add typeMapping --- exe-rel8-import/Main.hs | 34 +++++++++++++++++++++++++++++++--- 1 file changed, 31 insertions(+), 3 deletions(-) diff --git a/exe-rel8-import/Main.hs b/exe-rel8-import/Main.hs index f190ad7f..f1fb0961 100644 --- a/exe-rel8-import/Main.hs +++ b/exe-rel8-import/Main.hs @@ -16,6 +16,8 @@ module Main ( main ) where +import Data.Functor.Contravariant ( (>$<) ) +import Data.Maybe ( fromMaybe ) import qualified Data.ByteString.Char8 as BS import Options.Applicative ( Parser, strOption, long, info, execParser ) import Data.ByteString ( ByteString ) @@ -148,10 +150,10 @@ parser = do main :: IO () main = do Arguments{ connectionString, schema } <- execParser $ info parser mempty + c <- acquire connectionString >>= either (fail . show) return - Right c <- acquire connectionString tables <- select c do - table@PGClass{ oid = tableOid, relname, relnamespace } <- + table@PGClass{ oid = tableOid, relname, relnamespace } <- orderBy (relname >$< asc) do each pgclass >>= filter ((lit RTable ==.) . relkind) @@ -222,7 +224,11 @@ tablesToModule tables = HS.Module () Nothing pragmas imports allTableDecls field Attribute{ attribute, typ } = HS.FieldDecl () [fieldName] $ columnF columnType where fieldName = HS.Ident () $ camel $ unpack $ attname attribute - columnType = HS.TyCon () $ HS.UnQual () $ HS.Ident () $ pascal $ unpack $ typname typ + + columnType = + HS.TyCon () $ HS.UnQual () $ HS.Ident () $ + maybe (pascal $ unpack $ typname typ) unpack (lookup (typname typ) typeMapping) + columnF = HS.TyApp () (HS.TyApp () _Column f) where _Column = HS.TyCon () $ HS.UnQual () $ HS.Ident () "Column" @@ -278,3 +284,25 @@ tablesToModule tables = HS.Module () Nothing pragmas imports allTableDecls where str = unpack $ attname attribute + +typeMapping :: [(Text, Text)] +typeMapping = + [ ("bool", "Bool") + , ("char", "Char") + , ("float8", "Double") + , ("int2", "Int16") + , ("int4", "Int32") + , ("int8", "Int64") + , ("bytea", "ByteString") + , ("numeric", "Scientific") + , ("text", "Text") + , ("varchar", "Text") + , ("timestamptz", "UTCTime") + , ("jsonb", "Value") + , ("uuid", "UUID") + , ("interval", "CalendarDiffTime") + , ("date", "Day") + , ("time", "TimeOfDay") + , ("timestamp", "LocalTime") + , ("citext", "CI Text") + ]