postgresql-query 2.2.0 → 2.3.0
raw patch · 8 files changed
+415/−225 lines, 8 filesdep +inflectionsdep ~base
Dependencies added: inflections
Dependency ranges changed: base
Files
- CHANGELOG.md +6/−0
- example/Main.hs +28/−0
- postgresql-query.cabal +23/−1
- src/Database/PostgreSQL/Query/TH.hs +11/−224
- src/Database/PostgreSQL/Query/TH/Common.hs +34/−0
- src/Database/PostgreSQL/Query/TH/Entity.hs +100/−0
- src/Database/PostgreSQL/Query/TH/Enum.hs +125/−0
- src/Database/PostgreSQL/Query/TH/Row.hs +88/−0
CHANGELOG.md view
@@ -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 view
@@ -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 view
@@ -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 @@ , 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 @@ , 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@@ -111,3 +116,20 @@ , tasty-quickcheck , tasty-th , 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 view
@@ -1,219 +1,21 @@ 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 @@ [ 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 view
@@ -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
+ src/Database/PostgreSQL/Query/TH/Entity.hs view
@@ -0,0 +1,100 @@+module Database.PostgreSQL.Query.TH.Entity+ ( EntityOptions(..)+ , deriveEntity+ ) where++import Prelude++import Data.Default+import Data.String+import Database.PostgreSQL.Query.Entity ( Entity(..) )+import Database.PostgreSQL.Query.TH.Common+import Database.PostgreSQL.Query.Types ( FN(..) )+import Database.PostgreSQL.Simple.FromField+import Database.PostgreSQL.Simple.ToField+import GHC.Generics (Generic)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Text.Inflections++-- | 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+ } deriving (Generic)++instance Default EntityOptions where+ def = EntityOptions+ { eoTableName = toUnderscore+ , eoColumnNames = toUnderscore+ , eoDeriveClasses = [ ''Ord, ''Eq, ''Show+ , ''FromField, ''ToField ]+ , 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]
+ src/Database/PostgreSQL/Query/TH/Enum.hs view
@@ -0,0 +1,125 @@++-- | Helps to map enum types to postgresql enums.+module Database.PostgreSQL.Query.TH.Enum+ ( derivePgEnum+ , InflectorFunc+ ) where++import Prelude++import Data.FileEmbed+import Database.PostgreSQL.Simple.FromField+import Database.PostgreSQL.Simple.ToField+import Language.Haskell.TH++import qualified Data.Text.Encoding as T+import qualified Data.Text as T++-- | Function to transform constructor name into its PG enum conterpart.+type InflectorFunc = String -> String++{-| derives 'FromField' and 'ToField' instances for a sum-type enum like++@+data Entity = Red | Green | Blue+@+-}+derivePgEnum+ :: InflectorFunc+ -- ^ mapping function from haskell constructor name to PG enum label+ -> Name+ -- ^ type to derive instances for+ -> DecsQ+derivePgEnum infl typeName = do+ info <- reify typeName+ case info of+ TyConI dec ->+ case dec of+ DataD _ _ _ constructors _ -> do+ tfInstance <- makeToField infl typeName constructors+ ffInstance <- makeFromField infl typeName constructors+ pure [tfInstance, ffInstance]+ node -> error+ $ "unsupported constructor type "+ ++ show node+ ++ "in makePgEnumExplicit"+ node -> error+ $ "unsupported type "+ ++ show node+ ++ " in makePgEnumExplicit"++makeToField :: InflectorFunc+ -> Name+ -> [Con]+ -> DecQ+makeToField i typeName constr = do+ clauses <- traverse (makeToFieldClause i) constr+ instanceD+ (pure [])+ (appT (conT ''ToField) (conT typeName))+ [funD 'toField $ fmap pure clauses]++makeFromField :: InflectorFunc+ -> Name+ -> [Con]+ -> Q Dec+makeFromField i typeName enumCons = do+ f <- newName "f"+ mb <- newName "mb"+ byteSt <- newName "bs"+ hName <- newName "h"+ let+ otherw = (,)+ <$> normalG [|otherwise|]+ <*> [|returnError ConversionFailed $(varE f) (show $(varE mb))|]+ guards = map (makeFromFieldGuard i hName) enumCons ++ [otherw]+ helper =+ funD+ hName+ [clause+ [varP byteSt]+ (normalB [|((Just True) ==) (fmap (== $(varE byteSt)) $(varE mb))|])+ []+ ]+ instanceD+ (pure [])+ (appT (conT ''FromField) (conT typeName))+ [funD 'fromField [clause [varP f, varP mb] (guardedB guards) [helper]]]++makeFromFieldGuard :: InflectorFunc+ -> Name -- ^ shared helper function+ -> Con -- ^ constructor name+ -> Q (Guard, Exp)+makeFromFieldGuard i typeName con =+ flip (withEnumConstructor i) con $ \nam ec -> do+ let constr = conE nam+ guard <- normalG $ appE (varE typeName) ec+ expr <- appE (varE 'pure) constr+ pure (guard, expr)++makeToFieldClause :: InflectorFunc+ -> Con+ -> ClauseQ+makeToFieldClause i con =+ flip (withEnumConstructor i) con $ \nam ec -> do+ clause [conP nam []] (normalB [|Escape $ec|]) []++-- | Takes constructor w/o arguments and apply callback function.+-- Ejects with 'error' if called with wrong type of constructor.+withEnumConstructor :: InflectorFunc+ -- ^ function to transform the constructor name+ -> (Name -> ExpQ -> Q a)+ -- ^ callback function from:+ -- 1. haskell constructor name and+ -- 2. PG enum option (ByteString)+ -> Con+ -- ^ constructor to decompose+ -> Q a+withEnumConstructor i f = \case+ (NormalC _ (_:_)) ->+ error "constructors with arguments are not supported in makeToFieldClause"+ (NormalC nam [] ) -> f nam inflectedBs+ where inflectedT = T.pack $ i $ nameBase nam+ inflectedBs = bsToExp $ T.encodeUtf8 inflectedT+ _ ->+ error "unsupported constructor in makeFromFieldClause"
+ src/Database/PostgreSQL/Query/TH/Row.hs view
@@ -0,0 +1,88 @@+module Database.PostgreSQL.Query.TH.Row+ ( deriveFromRow+ , deriveToRow+ ) where++import Prelude++import Database.PostgreSQL.Query.TH.Common+import Database.PostgreSQL.Simple.FromRow ( FromRow(..), field )+import Database.PostgreSQL.Simple.ToRow ( ToRow(..) )+import Language.Haskell.TH+++{-| 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)++{-| 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