uhhh

persistent-postgresql/ChangeLog.md

@@ -1,5 +1,12 @@
 # Changelog for persistent-postgresql
 
+## 2.13.6 (unreleased)
+
+* [#1511](https://github.com/yesodweb/persistent/pull/1511)
+   * Add the `createPostgresqlPoolTailored` function to support creating
+     connection pools with a custom connection creation function.
+   * Expose `getServerVersion` and `createBackend` for user's convenience.
+
 ## 2.13.5.2
 
 * [#1471](https://github.com/yesodweb/persistent/pull/1471)

persistent-postgresql/Database/Persist/Postgresql.hs

@@ -37,6 +37,7 @@ module Database.Persist.Postgresql
     , createPostgresqlPool
     , createPostgresqlPoolModified
     , createPostgresqlPoolModifiedWithVersion
+    , createPostgresqlPoolTailored
     , createPostgresqlPoolWithConf
     , module Database.Persist.Sql
     , ConnectionString
@@ -52,6 +53,7 @@ module Database.Persist.Postgresql
     , upsertManyWhere
     , openSimpleConn
     , openSimpleConnWithVersion
+    , getServerVersion
     , getSimpleConn
     , tableName
     , fieldName
@@ -65,6 +67,7 @@ module Database.Persist.Postgresql
     , createRawPostgresqlPoolModified
     , createRawPostgresqlPoolModifiedWithVersion
     , createRawPostgresqlPoolWithConf
+    , createBackend
     ) where
 
 import qualified Database.PostgreSQL.LibPQ as LibPQ
@@ -82,8 +85,8 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift (MonadIO(..), MonadUnliftIO)
 import Control.Monad.Logger (MonadLoggerIO, runNoLoggingT)
-import Control.Monad.Trans.Reader (ReaderT(..), asks, runReaderT)
 import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Reader (ReaderT(..), asks, runReaderT)
 #if !MIN_VERSION_base(4,12,0)
 import Control.Monad.Trans.Reader (withReaderT)
 #endif
@@ -102,8 +105,8 @@ import qualified Data.Conduit.List as CL
 import Data.Data (Data)
 import Data.Either (partitionEithers)
 import Data.Function (on)
-import Data.IORef
 import Data.Int (Int64)
+import Data.IORef
 import Data.List (find, foldl', groupBy, sort)
 import qualified Data.List as List
 import Data.List.NonEmpty (NonEmpty)
@@ -122,12 +125,13 @@ import System.Environment (getEnvironment)
 #if MIN_VERSION_base(4,12,0)
 import Database.Persist.Compatible
 #endif
+import qualified Data.Vault.Strict as Vault
 import Database.Persist.Postgresql.Internal
 import Database.Persist.Sql
 import qualified Database.Persist.Sql.Util as Util
 import Database.Persist.SqlBackend
-import Database.Persist.SqlBackend.StatementCache (StatementCache, mkSimpleStatementCache, mkStatementCache)
-import qualified Data.Vault.Strict as Vault
+import Database.Persist.SqlBackend.StatementCache
+       (StatementCache, mkSimpleStatementCache, mkStatementCache)
 import System.IO.Unsafe (unsafePerformIO)
 
 -- | A @libpq@ connection string.  A simple example of connection
@@ -270,9 +274,31 @@ createPostgresqlPoolModifiedWithVersion
     -> ConnectionString -- ^ Connection string to the database.
     -> Int -- ^ Number of connections to be kept open in the pool.
     -> m (Pool SqlBackend)
-createPostgresqlPoolModifiedWithVersion getVerDouble modConn ci = do
+createPostgresqlPoolModifiedWithVersion = createPostgresqlPoolTailored open'
+
+-- | Same as 'createPostgresqlPoolModifiedWithVersion', but takes a custom connection-creation
+-- function.
+--
+-- The only time you should reach for this function is if you need to write custom logic for creating
+-- a connection to the database.
+--
+-- @since 2.13.6
+createPostgresqlPoolTailored
+    :: (MonadUnliftIO m, MonadLoggerIO m)
+    =>
+    (    (PG.Connection -> IO ())
+      -> (PG.Connection -> IO (NonEmpty Word))
+      -> ((PG.Connection -> SqlBackend) -> PG.Connection -> SqlBackend)
+      -> ConnectionString -> LogFunc -> IO SqlBackend
+    ) -- ^ Action that creates a postgresql connection (please see documentation on the un-exported @open'@ function in this same module.
+    -> (PG.Connection -> IO (Maybe Double)) -- ^ Action to perform to get the server version.
+    -> (PG.Connection -> IO ()) -- ^ Action to perform after connection is created.
+    -> ConnectionString -- ^ Connection string to the database.
+    -> Int -- ^ Number of connections to be kept open in the pool.
+    -> m (Pool SqlBackend)
+createPostgresqlPoolTailored createConnection getVerDouble modConn ci = do
   let getVer = oldGetVersionToNew getVerDouble
-  createSqlPool $ open' modConn getVer id ci
+  createSqlPool $ createConnection modConn getVer id ci
 
 -- | Same as 'createPostgresqlPool', but can be configured with 'PostgresConf' and 'PostgresConfHooks'.
 --
@@ -333,6 +359,8 @@ open' modConn getVer constructor cstr logFunc = do
     return $ constructor (createBackend logFunc ver smap) conn
 
 -- | Gets the PostgreSQL server version
+--
+-- @since 2.13.6
 getServerVersion :: PG.Connection -> IO (Maybe Double)
 getServerVersion conn = do
   [PG.Only version] <- PG.query_ conn "show server_version";
@@ -415,6 +443,8 @@ getSimpleConn = Vault.lookup underlyingConnectionKey <$> getConnVault
 
 -- | Create the backend given a logging function, server version, mutable statement cell,
 -- and connection.
+--
+-- @since 2.13.6
 createBackend :: LogFunc -> NonEmpty Word
               -> IORef (Map.Map Text Statement) -> PG.Connection -> SqlBackend
 createBackend logFunc serverVersion smap conn =

persistent-postgresql/persistent-postgresql.cabal

@@ -1,5 +1,5 @@
 name:            persistent-postgresql
-version:         2.13.5.2
+version:         2.13.6
 license:         MIT
 license-file:    LICENSE
 author:          Felipe Lessa, Michael Snoyman <[email protected]>

persistent/ChangeLog.md

@@ -1,5 +1,10 @@
 # Changelog for persistent
 
+## 2.14.6.0
+
+* [#1503](https://github.com/yesodweb/persistent/pull/1503)
+    * Create Haddocks from entity documentation comments
+
 ## 2.14.5.2
 
 * [#1513](https://github.com/yesodweb/persistent/pull/1513)

persistent/Database/Persist/Quasi.hs

@@ -612,8 +612,8 @@ Likewise, the field documentation is present in the @fieldComments@ field on the
 "A user can be old, or young, and we care about\nthis for some reason."
 @
 
-Unfortunately, we can't use this to create Haddocks for you, because <https://gitlab.haskell.org/ghc/ghc/issues/5467 Template Haskell does not support Haddock yet>.
-@persistent@ backends *can* use this to generate SQL @COMMENT@s, which are useful for a database perspective, and you can use the <https://hackage.haskell.org/package/persistent-documentation @persistent-documentation@> library to render a Markdown document of the entity definitions.
+Since @persistent-2.14.6.0@, documentation comments are included in documentation generated using Haddock if `mpsEntityHaddocks` is enabled (defaults to False).
+@persistent@ backends can also use this to generate SQL @COMMENT@s, which are useful for a database perspective, and you can use the <https://hackage.haskell.org/package/persistent-documentation @persistent-documentation@> library to render a Markdown document of the entity definitions.
 
 = Sum types
 

persistent/Database/Persist/TH.hs

@@ -45,6 +45,7 @@ module Database.Persist.TH
     , mpsPrefixFields
     , mpsFieldLabelModifier
     , mpsConstraintLabelModifier
+    , mpsEntityHaddocks
     , mpsEntityJSON
     , mpsGenerateLenses
     , mpsDeriveInstances
@@ -1070,6 +1071,10 @@ data MkPersistSettings = MkPersistSettings
     -- Note: this setting is ignored if mpsPrefixFields is set to False.
     --
     -- @since 2.11.0.0
+    , mpsEntityHaddocks :: Bool
+    -- ^ Generate Haddocks from entity documentation comments. Default: False.
+    --
+    -- @since 2.14.6.0
     , mpsEntityJSON :: Maybe EntityJSON
     -- ^ Generate @ToJSON@/@FromJSON@ instances for each model types. If it's
     -- @Nothing@, no instances will be generated. Default:
@@ -1161,6 +1166,7 @@ mkPersistSettings backend = MkPersistSettings
     , mpsPrefixFields = True
     , mpsFieldLabelModifier = (++)
     , mpsConstraintLabelModifier = (++)
+    , mpsEntityHaddocks = False
     , mpsEntityJSON = Just EntityJSON
         { entityToJSON = 'entityIdToJSON
         , entityFromJSON = 'entityIdFromJSON
@@ -1203,10 +1209,24 @@ dataTypeDec mps entityMap entDef = do
             pure (DerivClause (Just AnyclassStrategy) (fmap ConT anyclasses))
     unless (null anyclassDerives) $ do
         requireExtensions [[DeriveAnyClass]]
-    pure $ DataD [] nameFinal paramsFinal
+    let dec = DataD [] nameFinal paramsFinal
                 Nothing
                 constrs
                 (stockDerives <> anyclassDerives)
+#if MIN_VERSION_template_haskell(2,18,0)
+    when (mpsEntityHaddocks mps) $ do
+        forM_ cols $ \((name, _, _), maybeComments) -> do
+            case maybeComments of
+                Just comment -> addModFinalizer $
+                    putDoc (DeclDoc name) (unpack comment)
+                Nothing -> pure ()
+        case entityComments (unboundEntityDef entDef) of
+            Just doc -> do
+                addModFinalizer $ putDoc (DeclDoc nameFinal) (unpack doc)
+            _ -> pure ()
+#endif
+    pure dec
+
   where
     stratFor n =
         if n `elem` stockClasses then
@@ -1231,7 +1251,7 @@ dataTypeDec mps entityMap entDef = do
         | otherwise =
             (mkEntityDefName entDef, [])
 
-    cols :: [VarBangType]
+    cols :: [(VarBangType, Maybe Text)]
     cols = do
         fieldDef <- getUnboundFieldDefs entDef
         let
@@ -1243,11 +1263,13 @@ dataTypeDec mps entityMap entDef = do
                 else notStrict
             fieldIdType =
                 maybeIdType mps entityMap fieldDef Nothing Nothing
-        pure (recordNameE, strictness, fieldIdType)
+            fieldComments =
+                unboundFieldComments fieldDef
+        pure ((recordNameE, strictness, fieldIdType), fieldComments)
 
     constrs
         | unboundEntitySum entDef = fmap sumCon $ getUnboundFieldDefs entDef
-        | otherwise = [RecC (mkEntityDefName entDef) cols]
+        | otherwise = [RecC (mkEntityDefName entDef) (map fst cols)]
 
     sumCon fieldDef = NormalC
         (sumConstrName mps entDef fieldDef)

persistent/persistent.cabal

@@ -1,5 +1,5 @@
 name:            persistent
-version:         2.14.5.2
+version:         2.14.6.0
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <[email protected]>
@@ -173,6 +173,7 @@ test-suite test
         Database.Persist.TH.CompositeKeyStyleSpec
         Database.Persist.TH.DiscoverEntitiesSpec
         Database.Persist.TH.EmbedSpec
+        Database.Persist.TH.EntityHaddockSpec
         Database.Persist.TH.ForeignRefSpec
         Database.Persist.TH.ImplicitIdColSpec
         Database.Persist.TH.JsonEncodingSpec

persistent/test/Database/Persist/TH/CommentSpec.hs

@@ -12,14 +12,19 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-module Database.Persist.TH.CommentSpec where
+{-# OPTIONS_GHC -haddock #-}
+
+module Database.Persist.TH.CommentSpec
+    ( CommentModel (..)
+    , spec
+    ) where
 
 import TemplateTestImports
 
 import Database.Persist.EntityDef.Internal (EntityDef(..))
 import Database.Persist.FieldDef.Internal (FieldDef(..))
 
-mkPersist sqlSettings [persistLowerCase|
+mkPersist (sqlSettings {mpsEntityHaddocks = True}) [persistLowerCase|
 
 -- | Doc comments work.
 -- | Has multiple lines.

persistent/test/Database/Persist/TH/EntityHaddockSpec.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Database.Persist.TH.EntityHaddockSpec (spec) where
+
+import TemplateTestImports
+
+#if MIN_VERSION_template_haskell(2,18,0)
+import Database.Persist.TH.CommentSpec (CommentModel (..))
+import Language.Haskell.TH (DocLoc (DeclDoc), getDoc)
+import Language.Haskell.TH.Syntax (lift)
+
+[d|
+    commentModelDoc :: Maybe String
+    commentModelDoc = $(lift =<< getDoc (DeclDoc ''CommentModel))
+
+    commentFieldDoc :: Maybe String
+    commentFieldDoc = $(lift =<< getDoc (DeclDoc 'commentModelName))
+    |]
+
+spec :: Spec
+spec = describe "EntityHaddockSpec" $ do
+    it "generates entity Haddock" $ do
+        let expected = unlines [ "Doc comments work."
+                               , "Has multiple lines."
+                               ]
+        commentModelDoc `shouldBe` Just expected
+    it "generates field Haddock" $ do
+        let expected = unlines [ "First line of comment on column."
+                               , "Second line of comment on column."
+                               ]
+        commentFieldDoc `shouldBe` Just expected
+#else
+spec :: Spec
+spec = pure ()
+#endif

persistent/test/Database/Persist/THSpec.hs

@@ -53,6 +53,7 @@ import qualified Database.Persist.TH.CommentSpec as CommentSpec
 import qualified Database.Persist.TH.CompositeKeyStyleSpec as CompositeKeyStyleSpec
 import qualified Database.Persist.TH.DiscoverEntitiesSpec as DiscoverEntitiesSpec
 import qualified Database.Persist.TH.EmbedSpec as EmbedSpec
+import qualified Database.Persist.TH.EntityHaddockSpec as EntityHaddockSpec
 import qualified Database.Persist.TH.ForeignRefSpec as ForeignRefSpec
 import qualified Database.Persist.TH.ImplicitIdColSpec as ImplicitIdColSpec
 import qualified Database.Persist.TH.JsonEncodingSpec as JsonEncodingSpec
@@ -204,6 +205,7 @@ spec = describe "THSpec" $ do
     ToFromPersistValuesSpec.spec
     JsonEncodingSpec.spec
     CommentSpec.spec
+    EntityHaddockSpec.spec
     CompositeKeyStyleSpec.spec
     describe "TestDefaultKeyCol" $ do
         let EntityIdField FieldDef{..} =