diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 802a6fc..c57e33a 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -625,6 +625,15 @@ module Main (module Main) where #test export-with-things module Main (Test(Test, a, b)) where +#test export-with-things-comment +-- comment1 + +module Main + ( Test(Test, a, b) + , foo -- comment2 + ) -- comment3 +where + #test export-with-empty-thing module Main (Test()) where diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 25b7b9a..a283e89 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -16,7 +16,7 @@ where #include "prelude.inc" import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import Data.Data @@ -133,7 +133,7 @@ parsePrintModule configRaw inputText = runExceptT $ do -- can occur. pPrintModule :: Config - -> ExactPrint.Types.Anns + -> ExactPrint.Anns -> GHC.ParsedSource -> ([BrittanyError], TextL.Text) pPrintModule conf anns parsedModule = @@ -169,7 +169,7 @@ pPrintModule conf anns parsedModule = -- if it does not. pPrintModuleAndCheck :: Config - -> ExactPrint.Types.Anns + -> ExactPrint.Anns -> GHC.ParsedSource -> IO ([BrittanyError], TextL.Text) pPrintModuleAndCheck conf anns parsedModule = do @@ -253,7 +253,7 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do post <- ppPreamble lmod decls `forM_` \decl -> do filteredAnns <- mAsk <&> \annMap -> - Map.findWithDefault Map.empty (ExactPrint.Types.mkAnnKey decl) annMap + Map.findWithDefault Map.empty (ExactPrint.mkAnnKey decl) annMap traceIfDumpConf "bridoc annotations filtered/transformed" _dconf_dump_annotations @@ -266,26 +266,26 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do ppDecl decl let finalComments = filter ( fst .> \case - ExactPrint.Types.AnnComment{} -> True + ExactPrint.AnnComment{} -> True _ -> False ) post post `forM_` \case - (ExactPrint.Types.AnnComment (ExactPrint.Types.Comment cmStr _ _), l) -> do + (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do ppmMoveToExactLoc l mTell $ Text.Builder.fromString cmStr - (ExactPrint.Types.G AnnEofPos, (ExactPrint.Types.DP (eofX, eofY))) -> + (ExactPrint.G AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> let - folder (acc, _) (kw, ExactPrint.Types.DP (x, y)) = case kw of - ExactPrint.Types.AnnComment cm - | GHC.RealSrcSpan span <- ExactPrint.Types.commentIdentifier cm - -> ( acc + x + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span - , y + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span + folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of + ExactPrint.AnnComment cm + | GHC.RealSrcSpan span <- ExactPrint.commentIdentifier cm + -> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span + , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span ) - _ -> (acc + x, y) - (cmX, cmY) = foldl' folder (0, 0) finalComments + _ -> (acc + y, x) + (cmY, cmX) = foldl' folder (0, 0) finalComments in - ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY - cmY) + ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) _ -> return () withTransformedAnns :: Data ast => ast -> PPMLocal () -> PPMLocal () @@ -323,23 +323,23 @@ ppDecl d@(L loc decl) = case decl of -- Prints the information associated with the module annotation -- This includes the imports ppPreamble :: GenLocated SrcSpan (HsModule RdrName) - -> PPM [(ExactPrint.Types.KeywordId, ExactPrint.Types.DeltaPos)] + -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] ppPreamble lmod@(L _ (HsModule _ _ _ _ _ _)) = do filteredAnns <- mAsk <&> \annMap -> - Map.findWithDefault Map.empty (ExactPrint.Types.mkAnnKey lmod) annMap + Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap -- Since ghc-exactprint adds annotations following (implicit) -- modules to both HsModule and the elements in the module -- this can cause duplication of comments. So strip -- attached annotations that come after the module's where -- from the module node let (filteredAnns', post) = - case (ExactPrint.Types.mkAnnKey lmod) `Map.lookup` filteredAnns of + case (ExactPrint.mkAnnKey lmod) `Map.lookup` filteredAnns of Nothing -> (filteredAnns, []) Just mAnn -> - let modAnnsDp = ExactPrint.Types.annsDP mAnn - isWhere (ExactPrint.Types.G AnnWhere) = True + let modAnnsDp = ExactPrint.annsDP mAnn + isWhere (ExactPrint.G AnnWhere) = True isWhere _ = False - isEof (ExactPrint.Types.G AnnEofPos) = True + isEof (ExactPrint.G AnnEofPos) = True isEof _ = False whereInd = List.findIndex (isWhere . fst) modAnnsDp eofInd = List.findIndex (isEof . fst) modAnnsDp @@ -348,8 +348,22 @@ ppPreamble lmod@(L _ (HsModule _ _ _ _ _ _)) = do (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp (Nothing, Just _i) -> ([], modAnnsDp) (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp - mAnn' = mAnn { ExactPrint.Types.annsDP = pre } - filteredAnns'' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' filteredAnns + findInitialCommentSize = \case + ((ExactPrint.AnnComment cm, ExactPrint.DP (y, _)):rest) -> + let GHC.RealSrcSpan span = ExactPrint.commentIdentifier cm + in y + + GHC.srcSpanEndLine span + - GHC.srcSpanStartLine span + + findInitialCommentSize rest + _ -> 0 + initialCommentSize = findInitialCommentSize pre + fixAbsoluteModuleDP = \case + (g@(ExactPrint.G AnnModule), ExactPrint.DP (y, x)) -> + (g, ExactPrint.DP (y - initialCommentSize, x)) + x -> x + pre' = map fixAbsoluteModuleDP pre + mAnn' = mAnn { ExactPrint.annsDP = pre' } + filteredAnns'' = Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns in (filteredAnns'', post') in do traceIfDumpConf "bridoc annotations filtered/transformed" @@ -415,7 +429,7 @@ layoutBriDoc briDoc = do -- simpl <- mGet <&> transformToSimple -- return simpl - anns :: ExactPrint.Types.Anns <- mAsk + anns :: ExactPrint.Anns <- mAsk let state = LayoutState { _lstate_baseYs = [0] diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index c121eaf..c9da940 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -250,6 +250,23 @@ layoutBriDocM = \case -- layoutMoveToIndentCol y layoutWriteAppendMultiline $ Text.pack $ comment -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } + BDMoveToKWDP annKey keyword bd -> do + mDP <- do + state <- mGet + let m = _lstate_comments state + let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m + let relevant = [ dp + | Just ann <- [mAnn] + , (ExactPrint.Types.G kw1, dp) <- ann + , keyword == kw1 + ] + pure $ case relevant of + [] -> Nothing + (dp:_) -> Just dp + case mDP of + Nothing -> pure () + Just (ExactPrint.Types.DP (y, x)) -> layoutMoveToCommentPos y x + layoutBriDocM bd BDNonBottomSpacing bd -> layoutBriDocM bd BDSetParSpacing bd -> layoutBriDocM bd BDForceParSpacing bd -> layoutBriDocM bd @@ -282,6 +299,7 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc BDAnnotationPrior _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ bd -> rec bd BDLines ls@(_:_) -> do x <- StateS.get return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x @@ -317,6 +335,7 @@ briDocIsMultiLine briDoc = rec briDoc BDAnnotationPrior _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ bd -> rec bd BDLines (_:_:_) -> True BDLines [_ ] -> False BDLines [] -> error "briDocIsMultiLine BDLines []" diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 151dd65..89c8ae3 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -16,6 +16,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docSeq , docPar , docNodeAnnKW + , docNodeMoveToKWDP , docWrapNode , docWrapNodePrior , docWrapNodeRest @@ -29,6 +30,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docAnnotationPrior , docAnnotationKW , docAnnotationRest + , docMoveToKWDP , docNonBottomSpacing , docSetParSpacing , docForceParSpacing @@ -441,6 +443,13 @@ docAnnotationKW -> ToBriDocM BriDocNumbered docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm +docMoveToKWDP + :: AnnKey + -> AnnKeywordId + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +docMoveToKWDP annKey kw bdm = allocateNode . BDFMoveToKWDP annKey kw =<< bdm + docAnnotationRest :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm @@ -481,6 +490,15 @@ docNodeAnnKW docNodeAnnKW ast kw bdm = docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm +docNodeMoveToKWDP + :: Data.Data.Data ast + => Located ast + -> AnnKeywordId + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +docNodeMoveToKWDP ast kw bdm = + docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw bdm + class DocWrapable a where docWrapNode :: ( Data.Data.Data ast) => Located ast diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 126d519..bc277bc 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -117,8 +117,8 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do -- () -- no comments -- ( -- a comment -- ) -layoutLLIEs :: Located [LIE RdrName] -> ToBriDocM BriDocNumbered -layoutLLIEs llies = do +layoutLLIEs :: Bool -> Located [LIE RdrName] -> ToBriDocM BriDocNumbered +layoutLLIEs enableSingleline llies = do ieDs <- layoutAnnAndSepLLIEs llies hasComments <- hasAnyCommentsBelow llies case ieDs of @@ -130,7 +130,7 @@ layoutLLIEs llies = do ) ] (ieDsH:ieDsT) -> docAltFilter - [ ( not hasComments + [ ( not hasComments && enableSingleline , docSeq $ [docLit (Text.pack "(")] ++ (docForceSingleline <$> ieDs) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 613f2d2..e7fb03c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -84,7 +84,7 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of Just (_, llies) -> do hasComments <- hasAnyCommentsBelow llies if compact - then docSeq [hidDoc, layoutLLIEs llies] + then docSeq [hidDoc, layoutLLIEs True llies] else do ieDs <- layoutAnnAndSepLLIEs llies docWrapNodeRest llies $ case ieDs of diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index db2e2af..4620307 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -24,35 +24,37 @@ import Language.Haskell.Brittany.Internal.Utils layoutModule :: ToBriDoc HsModule -layoutModule lmod@(L _ mod') = - case mod' of +layoutModule lmod@(L _ mod') = case mod' of -- Implicit module Main - HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports - HsModule (Just n) les imports _ _ _ -> do - let tn = Text.pack $ moduleNameString $ unLoc n - exportsDoc = maybe docEmpty layoutLLIEs les - docLines - $ docSeq - [ docWrapNode lmod docEmpty - -- A pseudo node that serves merely to force documentation - -- before the node - , docAlt - ( [ docForceSingleline $ docSeq - [ appSep $ docLit $ Text.pack "module" - , appSep $ docLit tn - , appSep exportsDoc - , docLit $ Text.pack "where" - ] - ] - ++ [ docLines - [ docAddBaseY BrIndentRegular $ docPar - ( docSeq - [appSep $ docLit $ Text.pack "module", docLit tn] - ) - (docForceMultiline exportsDoc) - , docLit $ Text.pack "where" - ] - ] - ) - ] - : map layoutImport imports + HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports + HsModule (Just n) les imports _ _ _ -> do + let tn = Text.pack $ moduleNameString $ unLoc n + docLines + $ docSeq + [ docNodeAnnKW lmod Nothing docEmpty + -- A pseudo node that serves merely to force documentation + -- before the node + , docNodeMoveToKWDP lmod AnnModule $ docAlt + ( [ docForceSingleline $ docSeq + [ appSep $ docLit $ Text.pack "module" + , appSep $ docLit tn + , docWrapNode lmod $ appSep $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs True x + , docLit $ Text.pack "where" + ] + ] + ++ [ docLines + [ docAddBaseY BrIndentRegular $ docPar + (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] + ) + (docWrapNode lmod $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs False x + ) + , docLit $ Text.pack "where" + ] + ] + ) + ] + : map layoutImport imports diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 9c0a34e..c83cfae 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -301,6 +301,8 @@ transformAlts briDoc = reWrap . BDFAnnotationRest annKey <$> rec bd BDFAnnotationKW annKey kw bd -> reWrap . BDFAnnotationKW annKey kw <$> rec bd + BDFMoveToKWDP annKey kw bd -> + reWrap . BDFMoveToKWDP annKey kw <$> rec bd BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. BDFLines (l:lr) -> do ind <- _acp_indent <$> mGet @@ -460,6 +462,7 @@ getSpacing !bridoc = rec bridoc BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd BDFAnnotationRest _annKey bd -> rec bd + BDFMoveToKWDP _annKey _kw bd -> rec bd BDFLines [] -> return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False @@ -705,6 +708,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd BDFAnnotationRest _annKey bd -> rec bd + BDFMoveToKWDP _annKey _kw bd -> rec bd BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] BDFLines ls@(_:_) -> do -- we simply assume that lines is only used "properly", i.e. in diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index 071028a..41290a7 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -128,6 +128,7 @@ transformSimplifyColumns = Uniplate.rewrite $ \case BDAnnotationPrior{} -> Nothing BDAnnotationKW{} -> Nothing BDAnnotationRest{} -> Nothing + BDMoveToKWDP{} -> Nothing BDEnsureIndent{} -> Nothing BDSetParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 2784c1d..d321e21 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -233,6 +233,7 @@ data BriDoc | BDAnnotationPrior AnnKey BriDoc | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc | BDAnnotationRest AnnKey BriDoc + | BDMoveToKWDP AnnKey AnnKeywordId BriDoc | BDLines [BriDoc] | BDEnsureIndent BrIndent BriDoc -- the following constructors are only relevant for the alt transformation @@ -278,6 +279,7 @@ data BriDocF f | BDFAnnotationPrior AnnKey (f (BriDocF f)) | BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f)) | BDFAnnotationRest AnnKey (f (BriDocF f)) + | BDFMoveToKWDP AnnKey AnnKeywordId (f (BriDocF f)) | BDFLines [(f (BriDocF f))] | BDFEnsureIndent BrIndent (f (BriDocF f)) | BDFForceMultiline (f (BriDocF f)) @@ -311,6 +313,7 @@ instance Uniplate.Uniplate BriDoc where uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd uniplate (BDAnnotationRest annKey bd) = plate BDAnnotationRest |- annKey |* bd + uniplate (BDMoveToKWDP annKey kw bd) = plate BDMoveToKWDP |- annKey |- kw |* bd uniplate (BDLines lines) = plate BDLines ||* lines uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd @@ -342,6 +345,7 @@ unwrapBriDocNumbered tpl = case snd tpl of BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd + BDFMoveToKWDP annKey kw bd -> BDMoveToKWDP annKey kw $ rec bd BDFLines lines -> BDLines $ rec <$> lines BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd BDFForceMultiline bd -> BDForceMultiline $ rec bd @@ -377,6 +381,7 @@ briDocSeqSpine = \case BDAnnotationPrior _annKey bd -> briDocSeqSpine bd BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd BDAnnotationRest _annKey bd -> briDocSeqSpine bd + BDMoveToKWDP _annKey _kw bd -> briDocSeqSpine bd BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines BDEnsureIndent _ind bd -> briDocSeqSpine bd BDForceMultiline bd -> briDocSeqSpine bd