relational-query-postgresql-pure 0.1.0.0 → 0.1.1.0
raw patch · 4 files changed
+38/−51 lines, 4 filesdep −HDBCdep −Onlydep ~postgresql-purePVP ok
version bump matches the API change (PVP)
Dependencies removed: HDBC, Only
Dependency ranges changed: postgresql-pure
API changes (from Hackage documentation)
Files
- ChangeLog.md +7/−0
- relational-query-postgresql-pure.cabal +4/−6
- src/Database/Relational/PostgreSQL/Pure/TH.hs +26/−18
- test-db/Relation/Pure/Person.hs +1/−27
ChangeLog.md view
@@ -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
relational-query-postgresql-pure.cabal view
@@ -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
src/Database/Relational/PostgreSQL/Pure/TH.hs view
@@ -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
test-db/Relation/Pure/Person.hs view
@@ -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