diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 16a9362..6652443 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -19,6 +19,8 @@ import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation ) +import GHC ( AnnKeywordId (..) ) + import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.BackendUtils import Language.Haskell.Brittany.Internal.Utils @@ -173,6 +175,8 @@ layoutBriDocM = \case -- evil hack for CPP: case comment of ('#':_) -> layoutMoveToCommentPos y (-999) + "(" -> pure () + ")" -> layoutMoveToCommentPosX (x - 1) _ -> layoutMoveToCommentPos y x -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline @@ -244,6 +248,7 @@ layoutBriDocM = \case -- evil hack for CPP: case comment of ('#':_) -> layoutMoveToCommentPos y (-999) + ")" -> layoutMoveToCommentPosX (x - 1) _ -> layoutMoveToCommentPos y x -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index a7d8594..56b95bb 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -26,6 +26,7 @@ module Language.Haskell.Brittany.Internal.BackendUtils , layoutAddSepSpace , layoutSetCommentCol , layoutMoveToCommentPos + , layoutMoveToCommentPosX , layoutIndentRestorePostComment , moveToExactAnn , ppmMoveToExactLoc @@ -200,6 +201,17 @@ layoutMoveToCommentPos y x = do Right{} -> lstate_baseY state } +layoutMoveToCommentPosX + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => Int + -> m () +layoutMoveToCommentPosX x = do + traceLocal ("layoutMoveToCommentPosX", x) + state <- mGet + mSet state { _lstate_addSepSpace = Just $ _lstate_indLevelLinger state + x } -- | does _not_ add spaces to again reach the current base column. layoutWriteNewline diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index bfb129a..9f6366e 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -63,6 +63,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docSharedWrapper , hasAnyCommentsBelow , hasAnyCommentsConnected + , hasAnnKeywordComment , hasAnnKeyword ) where @@ -296,6 +297,15 @@ hasAnyCommentsConnected ast = do $ Map.elems $ anns +hasAnnKeywordComment + :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool +hasAnnKeywordComment ast annKeyword = do + anns <- mAsk + pure $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of + Nothing -> False + Just ann -> any hasK (extractAllComments ann) + where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst + hasAnnKeyword :: (Data a, MonadMultiReader (Map AnnKey Annotation) m) => Located a diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 49fbd12..4576e48 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -633,34 +633,41 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of Just (c, _) -> not (c == '(' || isUpper c) isInfix <- (isInfixTypeOp ||) <$> hasAnnKeyword name AnnBackquote #endif - docWrapNode ltycl $ layoutSynDecl isInfix name (hsq_explicit vars) typ + hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP + let parenWrapper = if hasTrailingParen + then appSep . docWrapNodeRest ltycl + else id + docWrapNodePrior ltycl + $ layoutSynDecl isInfix parenWrapper name (hsq_explicit vars) typ _ -> briDocByExactNoComment ltycl layoutSynDecl :: Bool + -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) -> Located (IdP GhcPs) -> [LHsTyVarBndr GhcPs] -> LHsType GhcPs -> ToBriDocM BriDocNumbered -layoutSynDecl isInfix name vars typ = do +layoutSynDecl isInfix parenWrapper name vars typ = do nameStr <- lrdrNameToTextAnn name let lhs = if isInfix then do let (a : b : rest) = vars + hasOwnParens <- hasAnnKeywordComment a AnnOpenP -- This isn't quite right, but does give syntactically valid results - hasParens = not $ null rest - docSeq + let needsParens = not $ null rest || hasOwnParens + parenWrapper . docSeq $ [ appSep $ docLit $ Text.pack "type" , appSep . docSeq - $ [ docParenL | hasParens ] + $ [ docParenL | needsParens ] ++ [ appSep $ layoutTyVarBndr a , appSep $ docLit nameStr , layoutTyVarBndr b ] - ++ [ docParenR | hasParens ] + ++ [ docParenR | needsParens ] ] ++ fmap (appSep . layoutTyVarBndr) rest else @@ -679,19 +686,22 @@ layoutSynDecl isInfix name vars typ = do ] layoutTyVarBndr :: ToBriDoc HsTyVarBndr -layoutTyVarBndr (L _ bndr) = case bndr of - UserTyVar name -> do - nameStr <- lrdrNameToTextAnn name - docLit nameStr - KindedTyVar name kind -> do - nameStr <- lrdrNameToTextAnn name - docSeq - [ docLit $ Text.pack "(" - , appSep $ docLit nameStr - , appSep . docLit $ Text.pack "::" - , docForceSingleline $ layoutType kind - , docLit $ Text.pack ")" - ] +layoutTyVarBndr lbndr@(L _ bndr) = do + needsPriorSpace <- hasAnnKeywordComment lbndr AnnCloseP + docWrapNodePrior lbndr $ case bndr of + UserTyVar name -> do + nameStr <- lrdrNameToTextAnn name + docSeq $ [ docSeparator | needsPriorSpace ] ++ [docLit nameStr] + KindedTyVar name kind -> do + nameStr <- lrdrNameToTextAnn name + docSeq + $ [ docSeparator | needsPriorSpace ] + ++ [ docLit $ Text.pack "(" + , appSep $ docLit nameStr + , appSep . docLit $ Text.pack "::" + , docForceSingleline $ layoutType kind + , docLit $ Text.pack ")" + ] --------------------------------------------------------------------------------