From 833ac95fd7ce764e93e2a4b20cda6c81341f1b53 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Mon, 12 Mar 2018 17:11:25 +0100
Subject: [PATCH] Add two config options to control preamble layouting
---
src-literatetests/Main.hs | 2 +
src-unittests/TestUtils.hs | 2 +
src/Language/Haskell/Brittany/Internal.hs | 101 ++++++++++--------
.../Haskell/Brittany/Internal/Config.hs | 4 +
.../Haskell/Brittany/Internal/Config/Types.hs | 15 +++
.../Brittany/Internal/Layouters/Module.hs | 14 +--
6 files changed, 87 insertions(+), 51 deletions(-)
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