postgresql-query 1.0.1 → 1.1.0
raw patch · 2 files changed
+188/−46 lines, 2 filesdep +data-default
Dependencies added: data-default
Files
- postgresql-query.cabal +6/−5
- src/Database/PostgreSQL/Query/TH.hs +182/−41
postgresql-query.cabal view
@@ -1,5 +1,5 @@ name: postgresql-query-version: 1.0.1+version: 1.1.0 synopsis: Sql interpolating quasiquote plus some kind of primitive ORM using it@@ -32,8 +32,7 @@ , Database.PostgreSQL.Query.TH.SqlExp , Database.PostgreSQL.Query.Types - default-extensions: TemplateHaskell- , CPP+ default-extensions: CPP , DeriveDataTypeable , DeriveGeneric , EmptyDataDecls@@ -50,6 +49,7 @@ , RecordWildCards , ScopedTypeVariables , StandaloneDeriving+ , TemplateHaskell , TupleSections , TypeFamilies , TypeOperators@@ -62,6 +62,7 @@ , blaze-builder , bytestring , containers+ , data-default , either , exceptions , file-embed@@ -91,9 +92,9 @@ hs-source-dirs: test main-is: Main.hs - default-extensions: OverloadedStrings+ default-extensions: FlexibleInstances+ , OverloadedStrings , TemplateHaskell- , FlexibleInstances build-depends: base >=4.6 && < 5 , QuickCheck
src/Database/PostgreSQL/Query/TH.hs view
@@ -2,6 +2,9 @@ ( -- * Deriving instances deriveFromRow , deriveToRow+ , deriveEntity+ , deriveEverything+ , EntityOptions(..) -- * Embedding sql files , embedSql , sqlFile@@ -14,45 +17,55 @@ import Prelude import Control.Applicative+import Data.Default import Data.FileEmbed ( embedFile )+import Database.PostgreSQL.Query.Entity ( Entity(..) )+import Database.PostgreSQL.Query.TH.SqlExp import Database.PostgreSQL.Simple.FromRow ( FromRow(..), field ) import Database.PostgreSQL.Simple.ToRow ( ToRow(..) ) import Database.PostgreSQL.Simple.Types ( Query(..) ) import Language.Haskell.TH-import Database.PostgreSQL.Query.TH.SqlExp -+-- | 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" --- | 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+-- | 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@@ -78,24 +91,26 @@ 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 ]--- @+{-| 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@@ -113,6 +128,132 @@ $ 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+ , eoDeriveClassess :: [Name] -- ^ Typeclasses to derive for Id+ , eoIdType :: Name -- ^ Base type for Id+ }++instance Default EntityOptions where+ def = EntityOptions+ { eoTableName = id+ , eoColumnNames = id+ , eoDeriveClassess = [''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+ , eoDeriveClassess =+ [''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 (eoDeriveClassess opts)+ tblName = eoTableName opts tnames+ fldNames = map (eoColumnNames opts . nameBase) $ cFieldNames tcon+ VarE ntableName <- [e|tableName|]+ VarE nfieldNames <- [e|fieldNames|]+ let tbldec = FunD ntableName [Clause [WildP] (NormalB $ LitE $ stringL tblName) []]+ flddec = FunD nfieldNames [Clause [WildP] (NormalB $ ListE $ map (LitE . stringL) fldNames) []]+ 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:++@+data Agent = Agent+ { aName :: !Text+ , aAttributes :: !HStoreMap+ , aLongWeirdName :: !Int+ } deriving (Ord, Eq, Show)++$(deriveEverything+ def { eoIdType = ''Id+ , eoTableName = toUnderscore+ , eoColumnNames = toUnderscore . drop 1+ , eoDeriveClassess =+ [''Show, ''Read, ''Ord, ''Eq+ , ''FromField, ''ToField, ''PathPiece]+ }+ ''Agent )+@++will generate that:++@+instance ToRow Agent where+ toRow (Agent a_aE3w a_aE3x a_aE3y)+ = [toField a_aE3w, toField a_aE3x, toField a_aE3y]+instance FromRow Agent where+ fromRow+ = Agent <$> Database.PostgreSQL.Simple.FromRow.field+ <*> Database.PostgreSQL.Simple.FromRow.field+ <*> Database.PostgreSQL.Simple.FromRow.field+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+@++-}++deriveEverything :: EntityOptions -> Name -> Q [Dec]+deriveEverything opts tname = fmap concat $ sequence+ [ deriveToRow tname+ , deriveFromRow tname+ , deriveEntity opts tname ] -- embed sql file as value embedSql :: String -- ^ File path