Create Haddocks from entity documentation comments

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.1
 
 * [#1496](https://github.com/yesodweb/persistent/pull/1496)

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
@@ -1067,6 +1068,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:
@@ -1158,6 +1163,7 @@ mkPersistSettings backend = MkPersistSettings
     , mpsPrefixFields = True
     , mpsFieldLabelModifier = (++)
     , mpsConstraintLabelModifier = (++)
+    , mpsEntityHaddocks = False
     , mpsEntityJSON = Just EntityJSON
         { entityToJSON = 'entityIdToJSON
         , entityFromJSON = 'entityIdFromJSON
@@ -1200,10 +1206,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
@@ -1228,7 +1248,7 @@ dataTypeDec mps entityMap entDef = do
         | otherwise =
             (mkEntityDefName entDef, [])
 
-    cols :: [VarBangType]
+    cols :: [(VarBangType, Maybe Text)]
     cols = do
         fieldDef <- getUnboundFieldDefs entDef
         let
@@ -1240,11 +1260,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.1
+version:         2.14.6.0
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -172,6 +172,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{..} =