diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Changelog for relational-query-postgresql-pure +## 0.1.1.0 + +2020.07.19 + +- A template Haskell function creates `ToRecord` and `FromRecord` instances and a `Length` type function. +- Remove a remaining HDBC dependency. + ## 0.1.0.0 2020.07.14 diff --git a/relational-query-postgresql-pure.cabal b/relational-query-postgresql-pure.cabal --- a/relational-query-postgresql-pure.cabal +++ b/relational-query-postgresql-pure.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 89378bd34b17a07ca7e04f4abc58ef676ab42e969ba1cce5f7d4bdb4681e7abd +-- hash: a388ed7b73f07b6922993e1a1f138c7ac8ce852d352fe1c90593e4136767d3c1 name: relational-query-postgresql-pure -version: 0.1.0.0 +version: 0.1.1.0 synopsis: The connector of relational-record and postgresql-pure. description: You can use postgresql-pure as the backend of relational-record without the HDBC interface. category: Database @@ -39,9 +39,7 @@ src ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wmissing-exported-signatures -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-name-shadowing -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-import-lists -Wmonomorphism-restriction build-depends: - HDBC - , Only - , base >=4 && <5 + base >=4 && <5 , containers , dlist , homotuple >=0.1.2.0 @@ -49,7 +47,7 @@ , names-th , persistable-record , postgresql-placeholder-converter - , postgresql-pure + , postgresql-pure >=0.2.2.0 , product-isomorphic , relational-query , relational-schemas diff --git a/src/Database/Relational/PostgreSQL/Pure/TH.hs b/src/Database/Relational/PostgreSQL/Pure/TH.hs --- a/src/Database/Relational/PostgreSQL/Pure/TH.hs +++ b/src/Database/Relational/PostgreSQL/Pure/TH.hs @@ -24,19 +24,20 @@ ) where import Control.Monad (void, when) -import Data.Functor.ProductIsomorphic.TH (reifyRecordType) import qualified Data.Map as Map import Data.Maybe (fromMaybe, listToMaybe) import Data.String (fromString) -import Database.HDBC (SqlValue) -import Database.PostgreSQL.Pure (ColumnInfo, Connection, Oid, disconnect, parse, sync) +import Database.PostgreSQL.Pure (ColumnInfo, Connection, FromRecord, Length, Oid, ToRecord, + disconnect, parse, sync) -import Language.Haskell.TH (Dec, Name, Q, Type (AppT, ConT), TypeQ, runIO) +import Language.Haskell.TH (Dec, Name, Q, TyLit (NumTyLit), Type (AppT, ConT, LitT), TypeQ, + runIO) import Language.Haskell.TH.Lib.Extra (reportError, reportWarning) import Language.Haskell.TH.Name.CamelCase (varCamelcaseName) +import Language.Haskell.TH.Syntax (returnQ) -import Database.Record.TH (defineSqlPersistableInstances, recordTemplate) +import Database.Record.TH (recordTemplate) import Database.Relational (Config, Relation, defaultConfig, enableWarning, nameConfig, recordConfig, relationalQuery_, untypeQuery, verboseAsCompilerWarning) @@ -47,18 +48,26 @@ getPrimaryKey, takeLogs) import Data.Tuple.Homotuple (IsHomolisttuple, IsHomotupleItem) -import Data.Tuple.List (Length) import GHC.TypeLits (KnownNat) +defineInstancesForRecord :: TypeQ -- ^ Record type constructor. + -> Q [Dec] -- ^ Instance declarations. +defineInstancesForRecord typeCon = do + [d| instance FromRecord $typeCon + instance ToRecord $typeCon + |] + +defineInstancesForLength :: TypeQ -> Int -> Q [Dec] +defineInstancesForLength typeCon len = do + let len' = returnQ $ LitT $ NumTyLit $ toInteger len + [d| type instance Length $typeCon = $len' |] + -- | Generate all persistable templates against defined record like type constructor. makeRelationalRecord' :: Config -> Name -- ^ Type constructor name -> Q [Dec] -- ^ Result declaration -makeRelationalRecord' config recTypeName = do - rr <- Relational.makeRelationalRecordDefault' config recTypeName - (((typeCon, avs), _), _) <- reifyRecordType recTypeName - ps <- defineSqlPersistableInstances [t| SqlValue |] typeCon avs - return $ rr ++ ps +makeRelationalRecord' config recTypeName = + Relational.makeRelationalRecordDefault' config recTypeName -- | Generate all persistable templates against defined record like type constructor. makeRelationalRecord :: Name -- ^ Type constructor name @@ -72,12 +81,8 @@ -> [(String, TypeQ)] -- ^ List of column name and type -> [Name] -- ^ Derivings -> Q [Dec] -- ^ Result declaration -defineTableDefault' config schema table columns derives = do - modelD <- Relational.defineTableTypesAndRecord config schema table columns derives - sqlvD <- defineSqlPersistableInstances [t| SqlValue |] - (fst $ recordTemplate (recordConfig $ nameConfig config) schema table) - [] - return $ modelD ++ sqlvD +defineTableDefault' config schema table columns derives = + Relational.defineTableTypesAndRecord config schema table columns derives -- | Generate all HDBC templates about table. defineTableDefault :: Config -- ^ Configuration to generate query with @@ -90,7 +95,10 @@ -> Q [Dec] -- ^ Result declaration defineTableDefault config schema table columns derives primary notNull = do modelD <- Relational.defineTable config schema table columns derives primary notNull - return modelD + let typeCon = fst $ recordTemplate (recordConfig $ nameConfig config) schema table + recordD <- defineInstancesForRecord typeCon + lengthD <- defineInstancesForLength typeCon $ length columns + return $ modelD ++ recordD ++ lengthD tableAlongWithSchema :: IO Connection -- ^ Connect action to system catalog database -> Driver -- ^ Driver definition diff --git a/test-db/Relation/Pure/Person.hs b/test-db/Relation/Pure/Person.hs --- a/test-db/Relation/Pure/Person.hs +++ b/test-db/Relation/Pure/Person.hs @@ -9,36 +9,10 @@ import DataSource.Pure (connect) -import Prelude (Maybe (Just, Nothing), Show (show), fail, length, sequence, - ($), (<$>), (<*>), (<>)) +import Prelude (Show) -import Database.PostgreSQL.Pure (FromRecord (fromRecord), Length, ToField (toField), - ToRecord (toRecord)) -import Database.PostgreSQL.Pure.Parser (column) import Database.Relational.PostgreSQL.Pure.TH (defineTableFromDB) import Database.Schema.PostgreSQL.Pure (driver) import GHC.Generics (Generic) defineTableFromDB connect driver "public" "person" [''Show, ''Generic] - -instance FromRecord Person where - fromRecord decode [i0, i1] = Person <$> column decode i0 <*> column decode i1 - fromRecord _ is = fail $ "length mismatch: expected 2: actual: " <> show (length is) - -instance ToRecord Person where - toRecord backendParams encode Nothing [f0, f1] (Person v0 v1) = - sequence - [ toField backendParams encode Nothing f0 v0 - , toField backendParams encode Nothing f1 v1 - ] - toRecord backendParams encode (Just [o0, o1]) [f0, f1] (Person v0 v1) = - sequence - [ toField backendParams encode (Just o0) f0 v0 - , toField backendParams encode (Just o1) f1 v1 - ] - toRecord _ _ (Just os) [_] _ = - fail $ "the number of OIDs must be 2, actually " <> show (length os) - toRecord _ _ _ fs _ = - fail $ "the number of format codes must be 2, actually " <> show (length fs) - -type instance Length Person = 2