Fix haddock comments on infix constructors

CHANGELOG.md

@@ -1,3 +1,8 @@
+## Unreleased
+
+* Fix Haddock comments on infix constructors
+  [Issue 758](https://github.com/tweag/ormolu/issues/758)
+
 ## Ormolu 0.7.5.0
 
 * Switched to `ghc-lib-parser-9.10`, with the following new syntactic features/behaviors:

data/examples/declaration/data/infix-haddocks-out.hs

@@ -0,0 +1,51 @@
+{- https://github.com/tweag/ormolu/issues/758 -}
+
+data A
+  = -- | Docs for :#
+    A :# A
+
+data WithDocs
+  = forall left right.
+    (Show left) =>
+    -- | Docs for left arg
+    left
+      -- | Docs for op
+      :*:
+      -- | Docs for right arg
+      right
+
+data MixedDocs
+  = forall left right.
+    (Show left) =>
+    left -- ^ before
+      :*:
+      -- | after
+      right
+
+data DocPartial
+  = Left -- ^ left docs
+    -- on multiple
+    -- lines
+      :*:
+      Right
+  | -- | op
+    Left
+      :*:
+      Right
+  | Left
+      :*:
+      -- | right
+      Right
+  | -- | op
+    Left
+      :*:
+      Right
+  | -- | op
+    Left
+      :*:
+      Right
+
+data NoDocs
+  = Left
+      :*:
+      Right

data/examples/declaration/data/infix-haddocks.hs

@@ -0,0 +1,43 @@
+{- https://github.com/tweag/ormolu/issues/758 -}
+
+data A = A :# A -- ^ Docs for :#
+
+data WithDocs
+  = forall left right.
+    Show left =>
+    left -- ^ Docs for left arg
+    :*: -- ^ Docs for op
+    right -- ^ Docs for right arg
+
+data MixedDocs
+  -- | before
+  = forall left right.
+    Show left =>
+    left :*: right
+  -- ^ after
+
+data DocPartial
+  = Left -- ^ left docs
+         -- on multiple
+         -- lines
+      :*: Right
+  | Left
+      :*: -- ^ op
+      Right
+  | Left
+      :*:
+      -- | right
+      Right
+  | -- | op
+    Left
+      :*:
+      Right
+  | Left
+      :*:
+      Right
+    -- ^ op
+
+data NoDocs
+  = Left
+    :*:
+    Right

src/Ormolu/Printer/Meat/Declaration/Data.hs

@@ -13,7 +13,7 @@ where
 import Control.Monad
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.List.NonEmpty qualified as NE
-import Data.Maybe (isJust, mapMaybe, maybeToList)
+import Data.Maybe (isJust, isNothing, mapMaybe, maybeToList)
 import GHC.Data.Strict qualified as Strict
 import GHC.Hs
 import GHC.Types.Fixity
@@ -190,16 +190,34 @@ p_conDecl singleConstRec ConDeclH98 {..} =
         p_rdrName con_name
         breakpoint
         inciIf (not singleConstRec) (located l p_conDeclFields)
-    InfixCon (HsScaled _ x) (HsScaled _ y) -> do
-      renderConDoc
+    InfixCon (HsScaled _ l) (HsScaled _ r) -> do
+      -- manually render these
+      let (lType, larg_doc) = splitDocTy l
+      let (rType, rarg_doc) = splitDocTy r
+
+      -- the constructor haddock can go on top of the entire constructor
+      -- only if neither argument has haddocks
+      let putConDocOnTop = isNothing larg_doc && isNothing rarg_doc
+
+      when putConDocOnTop renderConDoc
       renderContext
       switchLayout conDeclSpn $ do
-        located x p_hsType
+        -- the left arg haddock can use pipe only if the infix constructor has docs
+        if isJust con_doc
+          then do
+            mapM_ (p_hsDoc Pipe True) larg_doc
+            located lType p_hsType
+          else do
+            located lType p_hsType
+            space
+            mapM_ (p_hsDoc Caret False) larg_doc
         breakpoint
         inci $ do
+          unless putConDocOnTop renderConDoc
           p_rdrName con_name
-          space
-          located y p_hsType
+          breakpoint
+          mapM_ (p_hsDoc Pipe True) rarg_doc
+          located rType p_hsType
   where
     renderConDoc = mapM_ (p_hsDoc Pipe True) con_doc
     renderContext =
@@ -224,6 +242,10 @@ p_conDecl singleConstRec ConDeclH98 {..} =
       RecCon l -> [getLocA l]
       InfixCon x y -> getLocA . hsScaledThing <$> [x, y]
 
+    splitDocTy = \case
+      L _ (HsDocTy _ ty doc) -> (ty, Just doc)
+      ty -> (ty, Nothing)
+
 p_lhsContext ::
   LHsContext GhcPs ->
   R ()