ndmitchell · philderbeast · Feb 12, 2023 · Feb 14, 2023 · Jul 27, 2024 · Jul 31, 2024
diff --git a/empty-comment-block-haddocks.test b/empty-comment-block-haddocks.test
@@ -0,0 +1,21 @@
+{- |-}
+haddockAboveMultiEmpty = 1
+
+{- | -}
+haddockAboveMultiEmptySpace = 1
+
+{- |
+
+    -}
+haddockAboveMultiEmptyLines = 1
+
+haddockBelowMultiEmpty = 1
+{- ^-}
+
+haddockBelowMultiEmptySpace = 1
+{- ^-}
+
+haddockBelowMultiEmptyLines = 1
+{- ^
+
+    -}
diff --git a/empty-comment-blocks.test b/empty-comment-blocks.test
@@ -0,0 +1,12 @@
+{-##-}
+
+{--}
+commentMultiEmpty = 1
+
+{- -}
+commentMultiEmptySpace = 1
+
+{-
+
+    -}
+commentMultiEmptyLines = 1
diff --git a/empty-comment-mixed.test b/empty-comment-mixed.test
@@ -0,0 +1,11 @@
+-- |
+--
+-- Comment with blank line comment space above and below.
+--
+commentWithSpace = 1
+
+-- | Introduction line.
+--
+-- Comment with introduction line above and blank line below.
+--
+CommentWithSpaceOnlyAfter = 1
diff --git a/empty-comment-nonempty.test b/empty-comment-nonempty.test
@@ -0,0 +1,11 @@
+-- |
+--
+--
+-- foo
+haddockAboveIntoNonEmpty = 1
+
+haddockBelowIntoNonEmpty = 1
+-- ^
+--
+--
+-- foo
diff --git a/empty-comment-pragmas.test b/empty-comment-pragmas.test
@@ -0,0 +1,10 @@
+{-##-}
+pragmaEmpty = 1
+
+{-# #-}
+pragmaEmptySpace = 1
+
+{-#
+
+    #-}
+pragmaEmptyLines = 1
diff --git a/empty-comment-record.test b/empty-comment-record.test
@@ -0,0 +1,15 @@
+data HaddockSingle = HaddockSingle
+  { haddockFieldEmptyBelow :: Int
+  -- ^
+  -- |
+  , haddockFieldAboveEmpty :: Int
+  , haddockFieldEmptyAfter :: Int -- ^
+  }
+
+data HaddockMulti = HaddockMulti
+  { haddockFieldEmptyBelow :: Int
+  {- ^-}
+  {- |-}
+  , haddockFieldAboveEmpty :: Int
+  , haddockFieldEmptyAfter :: Int {- ^-}
+  }
diff --git a/empty-comment-single.test b/empty-comment-single.test
@@ -0,0 +1,5 @@
+-- |
+haddockAboveSingle = 1
+
+haddockBelowSingle = 1
+-- ^
diff --git a/empty-comment-singles.test b/empty-comment-singles.test
@@ -0,0 +1,7 @@
+-- |
+--
+haddockAboveSingles = 1
+
+-- |
+-- >>>
+haddockAboveDoctest = 1
diff --git a/example.test b/example.test
@@ -0,0 +1,73 @@
+-- | AA
+--
+--
+-- BB
+--
+--
+-- Comment with blank line comment space above and below.
+--
+--
+-- CC
+--
+--
+--
+--
+commentWithSpace = 1
+
+-- |
+--
+-- 11
+--
+--
+-- 22
+--
+--
+-- Comment with blank line comment space above and below.
+--
+--
+-- 33
+--
+commentWithSpace1 = 1
+
+commentWithSpace2 = 1
+-- ^
+--
+-- ZZ
+--
+--
+-- YY
+--
+--
+-- Comment with blank line comment space above and below.
+--
+--
+-- XX
+--
+
+-- | A comment as a string.
+
+{- |-}
+{--}
+
+--
+
+{-##-}
+
+-- |
+-- >>> :{
+--  let
+--    x = 1
+--    y = 2
+--  in x + y + multiline
+-- :}
+-- 6
+multiline = 3
+
+{- | >>> :{
+let x = 1
+    y = 2
+  in x + y + works
+:}
+6
+-}
+works = 3
diff --git a/src/GHC/Util/ApiAnnotation.hs b/src/GHC/Util/ApiAnnotation.hs
@@ -5,6 +5,8 @@ module GHC.Util.ApiAnnotation (
   , commentText
   , GHC.Util.ApiAnnotation.comments
   , isCommentMultiline
+  , isCommentPragma
+  , isCommentHaddock
   , pragmas
   , flags
   , languagePragmas
@@ -61,6 +63,18 @@ isCommentMultiline :: LEpaComment -> Bool
 isCommentMultiline (L _ (EpaComment (EpaBlockComment _) _)) = True
 isCommentMultiline _ = False
 
+isCommentPragma :: LEpaComment -> Bool
+isCommentPragma (L _ (EpaComment (EpaBlockComment comm) _)) =
+  "{-#" `isPrefixOf` comm && "#-}" `isSuffixOf` comm
+isCommentPragma _ = False
+
+isCommentHaddock :: LEpaComment -> Bool
+isCommentHaddock (L _ (EpaComment (EpaBlockComment comm) _)) =
+  ("{- |" `isPrefixOf` comm || "{- ^" `isPrefixOf` comm) && "-}" `isSuffixOf` comm
+isCommentHaddock (L _ (EpaComment (EpaLineComment comm) _)) =
+  "-- |" `isPrefixOf` comm || "-- ^" `isPrefixOf` comm
+isCommentHaddock _ = False
+
 -- Pragmas have the form @{-# ...#-}@.
 pragmas :: EpAnnComments -> [(LEpaComment, String)]
 pragmas x =