diff --git a/CHANGELOG.md b/CHANGELOG.md index f9319b9eb..22fd8c501 100644 --- a/CHANGELOG.md +++ b/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: diff --git a/data/examples/declaration/data/infix-haddocks-out.hs b/data/examples/declaration/data/infix-haddocks-out.hs new file mode 100644 index 000000000..acc653080 --- /dev/null +++ b/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 diff --git a/data/examples/declaration/data/infix-haddocks.hs b/data/examples/declaration/data/infix-haddocks.hs new file mode 100644 index 000000000..175f6a587 --- /dev/null +++ b/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 diff --git a/src/Ormolu/Printer/Meat/Declaration/Data.hs b/src/Ormolu/Printer/Meat/Declaration/Data.hs index 4a5486222..2919cd212 100644 --- a/src/Ormolu/Printer/Meat/Declaration/Data.hs +++ b/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 ()