diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 5567e68..47fd801 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -174,6 +174,8 @@ defaultTestConfig = Config , _lconfig_alignmentLimit = coerce (30 :: Int) , _lconfig_alignmentBreakOnMultiline = coerce True , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce True } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index 1ee5203..2e9487c 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -56,6 +56,8 @@ defaultTestConfig = Config , _lconfig_alignmentLimit = coerce (30 :: Int) , _lconfig_alignmentBreakOnMultiline = coerce True , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce True } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index a283e89..561390f 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -324,7 +324,7 @@ ppDecl d@(L loc decl) = case decl of -- This includes the imports ppPreamble :: GenLocated SrcSpan (HsModule RdrName) -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] -ppPreamble lmod@(L _ (HsModule _ _ _ _ _ _)) = do +ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do filteredAnns <- mAsk <&> \annMap -> Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap -- Since ghc-exactprint adds annotations following (implicit) @@ -332,52 +332,63 @@ ppPreamble lmod@(L _ (HsModule _ _ _ _ _ _)) = do -- 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.mkAnnKey lmod) `Map.lookup` filteredAnns of - Nothing -> (filteredAnns, []) - Just mAnn -> - let modAnnsDp = ExactPrint.annsDP mAnn - isWhere (ExactPrint.G AnnWhere) = True - isWhere _ = False - isEof (ExactPrint.G AnnEofPos) = True - isEof _ = False - whereInd = List.findIndex (isWhere . fst) modAnnsDp - eofInd = List.findIndex (isEof . fst) modAnnsDp - (pre, post') = case (whereInd, eofInd) of - (Nothing, Nothing) -> ([], modAnnsDp) - (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp - (Nothing, Just _i) -> ([], modAnnsDp) - (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp - 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" - _dconf_dump_annotations - $ annsDoc filteredAnns' + config <- mAsk + let shouldReformatPreamble = + config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack - config <- mAsk + let + (filteredAnns', post) = + case (ExactPrint.mkAnnKey lmod) `Map.lookup` filteredAnns of + Nothing -> (filteredAnns, []) + Just mAnn -> + let + modAnnsDp = ExactPrint.annsDP mAnn + isWhere (ExactPrint.G AnnWhere) = True + isWhere _ = False + isEof (ExactPrint.G AnnEofPos) = True + isEof _ = False + whereInd = List.findIndex (isWhere . fst) modAnnsDp + eofInd = List.findIndex (isEof . fst) modAnnsDp + (pre, post') = case (whereInd, eofInd) of + (Nothing, Nothing) -> ([], modAnnsDp) + (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp + (Nothing, Just _i) -> ([], modAnnsDp) + (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp + 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' = if shouldReformatPreamble + then map fixAbsoluteModuleDP pre + else pre + mAnn' = mAnn { ExactPrint.annsDP = pre' } + filteredAnns'' = + Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns + in + (filteredAnns'', post') + traceIfDumpConf "bridoc annotations filtered/transformed" + _dconf_dump_annotations + $ annsDoc filteredAnns' - MultiRWSS.withoutMultiReader $ do - MultiRWSS.mPutRawR $ config :+: filteredAnns' :+: HNil - withTransformedAnns lmod $ do - briDoc <- briDocMToPPM $ layoutModule lmod - layoutBriDoc briDoc - return post + if shouldReformatPreamble + then MultiRWSS.withoutMultiReader $ do + MultiRWSS.mPutRawR $ config :+: filteredAnns' :+: HNil + withTransformedAnns lmod $ do + briDoc <- briDocMToPPM $ layoutModule lmod + layoutBriDoc briDoc + else + let emptyModule = L loc m { hsmodDecls = [] } + in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule + return post _sigHead :: Sig RdrName -> String _sigHead = \case diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index ad991b5..d9266a9 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -64,6 +64,8 @@ staticDefaultConfig = Config , _lconfig_alignmentLimit = coerce (30 :: Int) , _lconfig_alignmentBreakOnMultiline = coerce True , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce False } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = coerce False @@ -158,6 +160,8 @@ configParser = do , _lconfig_alignmentLimit = mempty , _lconfig_alignmentBreakOnMultiline = mempty , _lconfig_hangingTypeSignature = mempty + , _lconfig_reformatModulePreamble = mempty + , _lconfig_allowSingleLineExportList = mempty } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index f2530b0..0f6d48b 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -84,6 +84,21 @@ data CLayoutConfig f = LayoutConfig -- -> SomeLongStuff -- As usual for hanging indentation, the result will be -- context-sensitive (in the function name). + , _lconfig_reformatModulePreamble :: f (Last Bool) + -- whether the module preamble/header (module keyword, name, export list, + -- import statements) are reformatted. If false, only the elements of the + -- module (everything past the "where") are reformatted. + , _lconfig_allowSingleLineExportList :: f (Last Bool) + -- if true, and it fits in a single line, and there are no comments in the + -- export list, the following layout will be used: + -- > module MyModule (abc, def) where + -- > [stuff] + -- otherwise, the multi-line version is used: + -- > module MyModule + -- > ( abc + -- > , def + -- > ) + -- > where } deriving (Generic) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 4620307..e9c9aa3 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -29,13 +29,17 @@ layoutModule lmod@(L _ mod') = case mod' of HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports HsModule (Just n) les imports _ _ _ -> do let tn = Text.pack $ moduleNameString $ unLoc n + allowSingleLineExportList <- mAsk + <&> _conf_layout + .> _lconfig_allowSingleLineExportList + .> confUnpack docLines $ docSeq [ docNodeAnnKW lmod Nothing docEmpty -- A pseudo node that serves merely to force documentation -- before the node - , docNodeMoveToKWDP lmod AnnModule $ docAlt - ( [ docForceSingleline $ docSeq + , docNodeMoveToKWDP lmod AnnModule $ docAltFilter + [ (,) allowSingleLineExportList $ docForceSingleline $ docSeq [ appSep $ docLit $ Text.pack "module" , appSep $ docLit tn , docWrapNode lmod $ appSep $ case les of @@ -43,8 +47,7 @@ layoutModule lmod@(L _ mod') = case mod' of Just x -> layoutLLIEs True x , docLit $ Text.pack "where" ] - ] - ++ [ docLines + , (,) otherwise $ docLines [ docAddBaseY BrIndentRegular $ docPar (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] ) @@ -54,7 +57,6 @@ layoutModule lmod@(L _ mod') = case mod' of ) , docLit $ Text.pack "where" ] - ] - ) + ] ] : map layoutImport imports