Deal with parens inside comments on 8.4.3
Rupert Horlick
parent
e1b43531a8
commit
b249c10054
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ")"
|
||||
]
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
Loading…
Reference in New Issue