diff --git a/postgresql-query.cabal b/postgresql-query.cabal --- a/postgresql-query.cabal +++ b/postgresql-query.cabal @@ -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 diff --git a/src/Database/PostgreSQL/Query/TH.hs b/src/Database/PostgreSQL/Query/TH.hs --- a/src/Database/PostgreSQL/Query/TH.hs +++ b/src/Database/PostgreSQL/Query/TH.hs @@ -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