hexagoxel
/
brittany
1
0
Fork 0
Code Issues 117 Pull Requests 5 Packages Projects Releases 5 Wiki Activity

Add two config options to control preamble layouting

pull/124/head
Lennart Spitzner 2018-03-12 17:11:25 +01:00
parent 9531edb2a7
commit 833ac95fd7
6 changed files with 87 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src-literatetests/Main.hs
View File

@ -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

2
src-unittests/TestUtils.hs
View File

@ -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

101
src/Language/Haskell/Brittany/Internal.hs
View File

@ -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

4
src/Language/Haskell/Brittany/Internal/Config.hs
View File

@ -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

15
src/Language/Haskell/Brittany/Internal/Config/Types.hs
View File

@ -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)

14
src/Language/Haskell/Brittany/Internal/Layouters/Module.hs
View File

@ -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