Merge branch 'release/2.3.0' into production

Author: s9gf4ult

.gitignore

@@ -4,3 +4,4 @@ cabal.sandbox.config
 *~
 TAGS
 cabal.config
+.stack-work

CHANGELOG.md

@@ -1,5 +1,11 @@
 # CHANGELOG
 
+## 2.3.0
+### Added
+* `derivePgEnum` TH generator for enum fields
+### Changed
+* TH code splitted to modules
+
 ## 2.2.0
 ### Added
 * `MonadHReader` instance for `PgMonadT`

example/Main.hs

@@ -0,0 +1,28 @@
+module Main where
+
+import Data.Text (Text)
+import Data.Time
+import Database.PostgreSQL.Query
+import Text.Inflections
+
+-- | Example enum type to check out how 'derivePgEnum' works
+data Species
+  = Dog
+  | Cat
+  | Snake
+
+derivePgEnum toUnderscore ''Species
+
+-- | Example structure to check out how 'deriveFromRow' works
+data AnimalInfo = AnimalInfo
+  { _aiName    :: Text
+  , _aiSpecies :: Species
+  , _aiBirtDay :: UTCTime
+  }
+
+deriveFromRow ''AnimalInfo
+deriveToRow ''AnimalInfo
+
+main :: IO ()
+main = do
+  return ()

postgresql-query.cabal

@@ -1,5 +1,5 @@
 name:                postgresql-query
-version:             2.2.0
+version:             2.3.0
 
 synopsis: Sql interpolating quasiquote plus some kind of primitive ORM
           using it
@@ -29,6 +29,10 @@ library
                  , Database.PostgreSQL.Query.Internal
                  , Database.PostgreSQL.Query.SqlBuilder
                  , Database.PostgreSQL.Query.TH
+                 , Database.PostgreSQL.Query.TH.Common
+                 , Database.PostgreSQL.Query.TH.Entity
+                 , Database.PostgreSQL.Query.TH.Enum
+                 , Database.PostgreSQL.Query.TH.Row
                  , Database.PostgreSQL.Query.TH.SqlExp
                  , Database.PostgreSQL.Query.Types
 
@@ -69,6 +73,7 @@ library
                , haskell-src-meta
                , hreader                       >= 1.0.0   && < 2.0.0
                , hset                          >= 2.0.0   && < 3.0.0
+               , inflections                   >= 0.2     && < 0.3
                , monad-control                 == 0.3.3.1 || > 1.0.0.3
                , monad-logger
                , mtl
@@ -110,4 +115,21 @@ test-suite test
                , tasty-hunit
                , tasty-quickcheck
                , tasty-th
-               , text
+               , text
+
+test-suite example
+  type:    exitcode-stdio-1.0
+  default-language:    Haskell2010
+  ghc-options:     -Wall
+  hs-source-dirs:  example
+  main-is: Main.hs
+
+  default-extensions: FlexibleInstances
+                    , OverloadedStrings
+                    , TemplateHaskell
+
+  build-depends: base
+               , inflections
+               , postgresql-query
+               , text
+               , time

src/Database/PostgreSQL/Query/TH.hs

@@ -1,218 +1,20 @@
 module Database.PostgreSQL.Query.TH
-       ( -- * Deriving instances
-         deriveFromRow
-       , deriveToRow
-       , deriveEntity
-       , deriveEverything
-       , EntityOptions(..)
-         -- * Embedding sql files
-       , embedSql
-       , sqlFile
-         -- * Sql string interpolation
-       , sqlExp
-       , sqlExpEmbed
-       , sqlExpFile
-       ) where
+  ( -- * Deriving instances
+    deriveEverything
+
+  , module Database.PostgreSQL.Query.TH.Entity
+  , module Database.PostgreSQL.Query.TH.Enum
+  , module Database.PostgreSQL.Query.TH.Row
+  , module Database.PostgreSQL.Query.TH.SqlExp
+  ) where
 
 import Prelude
 
-import Control.Applicative
-import Control.Monad
-import Data.Default
-import Data.FileEmbed ( embedFile )
-import Data.String
-import Database.PostgreSQL.Query.Entity ( Entity(..) )
+import Database.PostgreSQL.Query.TH.Entity
+import Database.PostgreSQL.Query.TH.Enum
+import Database.PostgreSQL.Query.TH.Row
 import Database.PostgreSQL.Query.TH.SqlExp
-import Database.PostgreSQL.Query.Types ( FN(..) )
-import Database.PostgreSQL.Simple.FromRow ( FromRow(..), field )
-import Database.PostgreSQL.Simple.ToRow ( ToRow(..) )
-import Database.PostgreSQL.Simple.Types ( Query(..) )
 import Language.Haskell.TH
-import Language.Haskell.TH.Syntax
-
--- | Return constructor name
-cName :: (Monad m) => Con -> m Name
-cName (NormalC n _) = return n
-cName (RecC n _) = return n
-cName _ = error "Constructor must be simple"
-
--- | Return count of constructor fields
-cArgs :: (Monad m) => Con -> m Int
-cArgs (NormalC _ n) = return $ length n
-cArgs (RecC _ n) = return $ length n
-cArgs _ = error "Constructor must be simple"
-
--- | Get field names from record constructor
-cFieldNames :: Con -> [Name]
-cFieldNames (RecC _ vst) = map (\(a, _, _) -> a) vst
-cFieldNames _ = error "Constructor must be a record (product type with field names)"
-
-{-| Derive 'FromRow' instance. i.e. you have type like that
-
-@
-data Entity = Entity
-              { eField :: Text
-              , eField2 :: Int
-              , efield3 :: Bool }
-@
-
-then 'deriveFromRow' will generate this instance:
-instance FromRow Entity where
-
-@
-instance FromRow Entity where
-    fromRow = Entity
-              \<$> field
-              \<*> field
-              \<*> field
-@
-
-Datatype must have just one constructor with arbitrary count of fields
--}
-
-deriveFromRow :: Name -> Q [Dec]
-deriveFromRow t = do
-    TyConI (DataD _ _ _ [con] _) <- reify t
-    cname <- cName con
-    cargs <- cArgs con
-    [d|instance FromRow $(return $ ConT t) where
-           fromRow = $(fieldsQ cname cargs)|]
-  where
-    fieldsQ cname cargs = do
-        fld <- [| field |]
-        fmp <- [| (<$>) |]
-        fap <- [| (<*>) |]
-        return $ UInfixE (ConE cname) fmp (fapChain cargs fld fap)
-
-    fapChain 0 _ _ = error "there must be at least 1 field in constructor"
-    fapChain 1 fld _ = fld
-    fapChain n fld fap = UInfixE fld fap (fapChain (n-1) fld fap)
-
-lookupVNameErr :: String -> Q Name
-lookupVNameErr name =
-    lookupValueName name >>=
-    maybe (error $ "could not find identifier: " ++ name)
-          return
-
-
-{-| derives 'ToRow' instance for datatype like
-
-@
-data Entity = Entity
-              { eField :: Text
-              , eField2 :: Int
-              , efield3 :: Bool }
-@
-
-it will derive instance like that:
-
-@
-instance ToRow Entity where
-     toRow (Entity e1 e2 e3) =
-         [ toField e1
-         , toField e2
-         , toField e3 ]
-@
--}
-
-deriveToRow :: Name -> Q [Dec]
-deriveToRow t = do
-    TyConI (DataD _ _ _ [con] _) <- reify t
-    cname <- cName con
-    cargs <- cArgs con
-    cvars <- sequence
-             $ replicate cargs
-             $ newName "a"
-    [d|instance ToRow $(return $ ConT t) where
-           toRow $(return $ ConP cname $ map VarP cvars) = $(toFields cvars)|]
-  where
-    toFields v = do
-        tof <- lookupVNameErr "toField"
-        return $ ListE
-            $ map
-            (\e -> AppE (VarE tof) (VarE e))
-            v
-
--- | Options for deriving `Entity`
-data EntityOptions = EntityOptions
-    { eoTableName      :: String -> String -- ^ Type name to table name converter
-    , eoColumnNames    :: String -> String -- ^ Record field to column name converter
-    , eoDeriveClasses  :: [Name]           -- ^ Typeclasses to derive for Id
-    , eoIdType         :: Name             -- ^ Base type for Id
-    }
-
-instance Default EntityOptions where
-    def = EntityOptions
-        { eoTableName = id
-        , eoColumnNames = id
-        , eoDeriveClasses = [''Ord, ''Eq, ''Show]
-        , eoIdType = ''Integer
-        }
-
-{- | Derives instance for 'Entity' using type name and field names. Also
-generates type synonim for ID. E.g. code like this:
-
-@
-data Agent = Agent
-    { aName          :: !Text
-    , aAttributes    :: !HStoreMap
-    , aLongWeirdName :: !Int
-    } deriving (Ord, Eq, Show)
-
-$(deriveEntity
-  def { eoIdType        = ''Id
-      , eoTableName     = toUnderscore
-      , eoColumnNames   = toUnderscore . drop 1
-      , eoDeriveClasses =
-        [''Show, ''Read, ''Ord, ''Eq
-        , ''FromField, ''ToField, ''PathPiece]
-      }
-  ''Agent )
-@
-
-Will generate code like this:
-
-@
-instance Database.PostgreSQL.Query.Entity Agent where
-    newtype EntityId Agent
-        = AgentId {getAgentId :: Id}
-        deriving (Show, Read, Ord, Eq, FromField, ToField, PathPiece)
-    tableName _ = "agent"
-    fieldNames _ = ["name", "attributes", "long_weird_name"]
-type AgentId = EntityId Agent
-@
-
-So, you dont need to write it by hands any more.
-
-NOTE: 'toUnderscore' is from package 'inflections' here
--}
-
-deriveEntity :: EntityOptions -> Name -> Q [Dec]
-deriveEntity opts tname = do
-    TyConI (DataD _ _ _ [tcon] _) <- reify tname
-    econt <- [t|Entity $(conT tname)|]
-    ConT entityIdName <- [t|EntityId|]
-    let tnames = nameBase tname
-        idname = tnames ++ "Id"
-        unidname = "get" ++ idname
-        idtype = ConT (eoIdType opts)
-        idcon = RecC (mkName idname)
-                [(mkName unidname, NotStrict, idtype)]
-        iddec = NewtypeInstD [] entityIdName [ConT tname]
-                idcon (eoDeriveClasses opts)
-        tblName = fromString $ eoTableName opts tnames
-        fldNames = map (fromString . eoColumnNames opts . nameBase)
-                   $ cFieldNames tcon
-    VarE ntableName  <- [e|tableName|]
-    VarE nfieldNames <- [e|fieldNames|]
-    tblExp <- lift (tblName :: FN)
-    fldExp <- mapM lift (fldNames :: [FN])
-    let tbldec = FunD ntableName  [Clause [WildP] (NormalB tblExp) []]
-        flddec = FunD nfieldNames [Clause [WildP] (NormalB $ ListE fldExp) []]
-        ret = InstanceD [] econt
-              [ iddec, tbldec, flddec ]
-        syndec = TySynD (mkName idname) [] (AppT (ConT entityIdName) (ConT tname))
-    return [ret, syndec]
 
 {- | Calls sequently `deriveFromRow` `deriveToRow` `deriveEntity`. E.g. code like this:
 
@@ -261,18 +63,3 @@ deriveEverything opts tname = fmap concat $ sequence
     [ deriveToRow tname
     , deriveFromRow tname
     , deriveEntity opts tname ]
-
--- embed sql file as value
-embedSql :: String               -- ^ File path
-         -> Q Exp
-embedSql path = do
-    [e| (Query ( $(embedFile path) )) |]
-{-# DEPRECATED embedSql "use 'sqlExpEmbed' instead" #-}
-
--- embed sql file by pattern. __sqlFile "dir/file"__ is just the same as
--- __embedSql "sql/dir/file.sql"__
-sqlFile :: String                -- ^ sql file pattern
-        -> Q Exp
-sqlFile s = do
-    embedSql $ "sql/" ++ s ++ ".sql"
-{-# DEPRECATED sqlFile "use 'sqlExpFile' instead" #-}

src/Database/PostgreSQL/Query/TH/Common.hs

@@ -0,0 +1,34 @@
+module Database.PostgreSQL.Query.TH.Common
+  ( cName
+  , cArgs
+  , cFieldNames
+  , lookupVNameErr
+  ) where
+
+import Prelude
+
+import Language.Haskell.TH
+
+-- | Return constructor name
+cName :: (Monad m) => Con -> m Name
+cName (NormalC n _) = return n
+cName (RecC n _) = return n
+cName _ = error "Constructor must be simple"
+
+-- | Return count of constructor fields
+cArgs :: (Monad m) => Con -> m Int
+cArgs (NormalC _ n) = return $ length n
+cArgs (RecC _ n) = return $ length n
+cArgs _ = error "Constructor must be simple"
+
+-- | Get field names from record constructor
+cFieldNames :: Con -> [Name]
+cFieldNames (RecC _ vst) = map (\(a, _, _) -> a) vst
+cFieldNames _ = error "Constructor must be a record (product type with field names)"
+
+
+lookupVNameErr :: String -> Q Name
+lookupVNameErr name =
+    lookupValueName name >>=
+    maybe (error $ "could not find identifier: " ++ name)
+          return