Merge pull request #83/#124 from sniperrifle2004/import

pull/132/head
Lennart Spitzner 2018-03-21 01:06:26 +01:00
commit f1536b8966
16 changed files with 1091 additions and 49 deletions

View File

@ -67,6 +67,9 @@ library {
Language.Haskell.Brittany.Internal.Layouters.Expr
Language.Haskell.Brittany.Internal.Layouters.Stmt
Language.Haskell.Brittany.Internal.Layouters.Pattern
Language.Haskell.Brittany.Internal.Layouters.IE
Language.Haskell.Brittany.Internal.Layouters.Import
Language.Haskell.Brittany.Internal.Layouters.Module
Language.Haskell.Brittany.Internal.Transformations.Alt
Language.Haskell.Brittany.Internal.Transformations.Floating
Language.Haskell.Brittany.Internal.Transformations.Par

View File

@ -565,3 +565,297 @@ func =
]
++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc]
###############################################################################
###############################################################################
###############################################################################
#group module
###############################################################################
###############################################################################
###############################################################################
#test simple
module Main where
#test no-exports
module Main () where
#test one-export
module Main (main) where
#test several-exports
module Main (main, test1, test2) where
#test many-exports
module Main
( main
, test1
, test2
, test3
, test4
, test5
, test6
, test7
, test8
, test9
)
where
#test exports-with-comments
module Main
( main
-- main
, test1
, test2
-- Test 3
, test3
, test4
-- Test 5
, test5
-- Test 6
)
where
#test simple-export-with-things
module Main (Test(..)) where
#test simple-export-with-module-contents
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
#test empty-with-comment
-- Intentionally left empty
###############################################################################
###############################################################################
###############################################################################
#group module.import
###############################################################################
###############################################################################
###############################################################################
#test simple-import
import Data.List
#test simple-import-alias
import Data.List as L
#test simple-qualified-import
import qualified Data.List
#test simple-qualified-import-alias
import qualified Data.List as L
#test simple-safe
import safe Data.List as L
#test simple-source
import {-# SOURCE #-} Data.List ( )
#test simple-safe-qualified
import safe qualified Data.List
#test simple-safe-qualified-source
import {-# SOURCE #-} safe qualified Data.List
#test simple-qualified-package
import qualified "base" Data.List
#test qualifier-effect
import {-# SOURCE #-} safe qualified "base" Data.List as L
import {-# SOURCE #-} safe qualified "base" Data.List ( )
import {-# SOURCE #-} safe qualified Data.List hiding ( )
#test instances-only
import qualified Data.List ( )
#test one-element
import Data.List ( nub )
#test several-elements
import Data.List ( nub
, foldl'
, indexElem
)
#test a-ridiculous-amount-of-elements
import Test ( Long
, list
, with
, items
, that
, will
, not
, quite
, fit
, onA
, single
, line
, anymore
)
#test with-things
import Test ( T
, T2()
, T3(..)
, T4(T4)
, T5(T5, t5)
, T6((<|>))
, (+)
)
#test hiding
import Test hiding ( )
import Test as T
hiding ( )
#test long-module-name
import TestJustShortEnoughModuleNameLikeThisOne ( )
import TestJustAbitToLongModuleNameLikeThisOneIs
( )
import TestJustShortEnoughModuleNameLikeThisOn as T
import TestJustAbitToLongModuleNameLikeThisOneI
as T
import TestJustShortEnoughModuleNameLike hiding ( )
import TestJustAbitToLongModuleNameLikeTh
hiding ( )
import MoreThanSufficientlyLongModuleNameWithSome
( items
, that
, will
, not
, fit
, inA
, compact
, layout
)
import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff ( )
import {-# SOURCE #-} safe qualified "qualifiers" AlsoAffe
( )
import {-# SOURCE #-} safe qualified "qualifiers" AlsoAf as T
import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff
as T
import {-# SOURCE #-} safe qualified "qualifier" A hiding ( )
import {-# SOURCE #-} safe qualified "qualifiers" A
hiding ( )
#test import-with-comments
-- Test
import Data.List ( nub ) -- Test
{- Test -}
import qualified Data.List as L
( foldl' ) {- Test -}
-- Test
import Test ( test )
#test import-with-comments-2
import Test ( abc
, def
-- comment
)
#test import-with-comments-3
import Test ( abc
-- comment
)
#test import-with-comments-4
import Test ( abc
-- comment
, def
, ghi
{- comment -}
, jkl
-- comment
)
#test import-with-comments-5
import Test ( -- comment
)
#test long-bindings
import Test ( longbindingNameThatoverflowsColum
)
import Test ( Long
( List
, Of
, Things
)
)
#test things-with-with-comments
import Test ( Thing
( -- Comments
)
)
import Test ( Thing
( Item
-- and Comment
)
)
import Test ( Thing
( With
-- Comments
, and
-- also
, items
-- !
)
)
#test prefer-dense-empty-list
import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine
( )
#test preamble full-preamble
{-# LANGUAGE BangPatterns #-}
{-
- Test module
-}
module Test
( test1
-- ^ test
, test2
-- | test
, test3
, test4
, test5
, test6
, test7
, test8
, test9
, test10
-- Test 10
)
where
-- Test
import Data.List ( nub ) -- Test
{- Test -}
import qualified Data.List as L
( foldl' ) {- Test -}
-- Test
import Test ( test )

View File

@ -169,11 +169,14 @@ defaultTestConfig = Config
, _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_importAsColumn = coerce (60 :: Int)
, _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
, _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

View File

@ -598,6 +598,259 @@ func =
]
++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc]
###############################################################################
###############################################################################
###############################################################################
#group module
###############################################################################
###############################################################################
###############################################################################
#test simple
module Main where
#test no-exports
module Main () where
#test one-export
module Main (main) where
#test several-exports
module Main (main, test1, test2) where
#test many-exports
module Main
( main
, test1
, test2
, test3
, test4
, test5
, test6
, test7
, test8
, test9
)
where
#test exports-with-comments
module Main
( main
-- main
, test1
, test2
-- Test 3
, test3
, test4
-- Test 5
, test5
-- Test 6
)
where
#test simple-export-with-things
module Main (Test(..)) where
#test simple-export-with-module-contents
module Main (module Main) where
#test export-with-things
module Main (Test(Test, a, b)) where
#test export-with-empty-thing
module Main (Test()) where
#test empty-with-comment
-- Intentionally left empty
###############################################################################
###############################################################################
###############################################################################
#group import
###############################################################################
###############################################################################
###############################################################################
#test simple-import
import Data.List
#test simple-import-alias
import Data.List as L
#test simple-qualified-import
import qualified Data.List
#test simple-qualified-import-alias
import qualified Data.List as L
#test simple-safe
import safe Data.List as L
#test simple-source
import {-# SOURCE #-} Data.List ()
#test simple-safe-qualified
import safe qualified Data.List hiding (nub)
#test simple-safe-qualified-source
import {-# SOURCE #-} safe qualified Data.List
#test simple-qualified-package
import qualified "base" Data.List
#test qualifier-effect
import {-# SOURCE #-} safe qualified "base" Data.List as L
import {-# SOURCE #-} safe qualified "base" Data.List ()
import {-# SOURCE #-} safe qualified Data.List hiding ()
#test instances-only
import qualified Data.List ()
#test one-element
import Data.List (nub)
#test several-elements
import Data.List (nub, foldl', indexElem)
#test a-ridiculous-amount-of-elements
import Test
( Long
, list
, with
, items
, that
, will
, not
, quite
, fit
, onA
, single
, line
, anymore
)
#test with-things
import Test (T, T2(), T3(..), T4(T4), T5(T5, t5), T6((<|>)), (+))
#test hiding
import Test hiding ()
import Test as T hiding ()
#test long-module-name
import TestJustShortEnoughModuleNameLikeThisOne ()
import TestJustAbitToLongModuleNameLikeThisOneIs ()
import TestJustShortEnoughModuleNameLikeThisOn as T
import TestJustAbitToLongModuleNameLikeThisOneI as T
import TestJustShortEnoughModuleNameLike hiding ()
import TestJustAbitToLongModuleNameLikeTh hiding ()
import MoreThanSufficientlyLongModuleNameWithSome
(items, that, will, not, fit, inA, compact, layout)
#test import-with-comments
-- Test
import Data.List (nub) -- Test
{- Test -}
import qualified Data.List as L (foldl') {- Test -}
#test import-with-comments-2
import Test
( abc
, def
-- comment
)
#test import-with-comments-3
import Test
( abc
-- comment
)
#test import-with-comments-4
import Test
( abc
-- comment
, def
, ghi
{- comment -}
, jkl
-- comment
)
-- Test
import Test (test)
#test import-with-comments-5
import Test
( -- comment
)
#test long-bindings
import Test (longbindingNameThatoverflowsColum)
import Test (Long(List, Of, Things))
#test things-with-with-comments
import Test
( Thing
( With
-- Comments
, and
-- also
, items
-- !
)
)
import Test
( Thing
( Item
-- and Comment
)
)
import Test
( Thing
( With
-- Comments
, and
-- also
, items
-- !
)
)
#test prefer-dense-empty-list
import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine
()
#test preamble full-preamble
{-# LANGUAGE BangPatterns #-}
{-
- Test module
-}
module Test
( test1
-- ^ test
, test2
-- | test
, test3
, test4
, test5
, test6
, test7
, test8
, test9
, test10
)
where
-- Test
import Data.List (nub) -- Test
{- Test -}
import qualified Data.List as L (foldl') {- Test -}
-- Test
import Test (test)
###############################################################################
###############################################################################
@ -1133,4 +1386,3 @@ foo =
## ]
## where
## role = stringProperty "WM_WINDOW_ROLE"

View File

@ -51,11 +51,14 @@ defaultTestConfig = Config
, _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_importAsColumn = coerce (60 :: Int)
, _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
, _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

View File

@ -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
@ -33,6 +33,7 @@ import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.Type
import Language.Haskell.Brittany.Internal.Layouters.Decl
import Language.Haskell.Brittany.Internal.Layouters.Module
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Backend
import Language.Haskell.Brittany.Internal.BackendUtils
@ -132,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 =
@ -160,7 +161,7 @@ pPrintModule conf anns parsedModule =
in
tracer $ (errs, Text.Builder.toLazyText out)
-- unless () $ do
--
--
-- debugStrings `forM_` \s ->
-- trace s $ return ()
@ -168,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
@ -248,33 +249,11 @@ parsePrintModuleTests conf filename input = do
-- else return $ TextL.toStrict $ Text.Builder.toLazyText out
ppModule :: GenLocated SrcSpan (HsModule RdrName) -> PPM ()
ppModule lmod@(L loc m@(HsModule _name _exports _imports decls _ _)) = do
let emptyModule = L loc m { hsmodDecls = [] }
(anns', post) <- do
anns <- mAsk
-- evil partiality. but rather unlikely.
return $ case Map.lookup (ExactPrint.Types.mkAnnKey lmod) anns of
Nothing -> (anns, [])
Just mAnn ->
let modAnnsDp = ExactPrint.Types.annsDP mAnn
isWhere (ExactPrint.Types.G AnnWhere) = True
isWhere _ = False
isEof (ExactPrint.Types.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
mAnn' = mAnn { ExactPrint.Types.annsDP = pre }
anns' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' anns
in (anns', post)
MultiRWSS.withMultiReader anns' $ processDefault emptyModule
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
@ -287,26 +266,26 @@ ppModule lmod@(L loc m@(HsModule _name _exports _imports 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 ()
@ -341,6 +320,76 @@ ppDecl d@(L loc decl) = case decl of
layoutBriDoc briDoc
_ -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc
-- Prints the information associated with the module annotation
-- This includes the imports
ppPreamble :: GenLocated SrcSpan (HsModule RdrName)
-> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)]
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)
-- 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
config <- mAsk
let shouldReformatPreamble =
config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack
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'
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
TypeSig names _ ->
@ -391,7 +440,7 @@ layoutBriDoc briDoc = do
-- simpl <- mGet <&> transformToSimple
-- return simpl
anns :: ExactPrint.Types.Anns <- mAsk
anns :: ExactPrint.Anns <- mAsk
let state = LayoutState
{ _lstate_baseYs = [0]

View File

@ -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 []"

View File

@ -65,12 +65,15 @@ staticDefaultConfig = Config
, _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_importColumn = coerce (50 :: Int)
, _lconfig_importAsColumn = coerce (50 :: Int)
, _lconfig_altChooser = coerce (AltChooserBoundedSearch 3)
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
, _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
@ -111,6 +114,7 @@ configParser = do
ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level")
cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)")
importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at")
importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at")
dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)")
dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint")
@ -160,11 +164,14 @@ configParser = do
, _lconfig_indentWhereSpecial = mempty -- falseToNothing _
, _lconfig_indentListSpecial = mempty -- falseToNothing _
, _lconfig_importColumn = optionConcat importCol
, _lconfig_importAsColumn = optionConcat importAsCol
, _lconfig_altChooser = mempty
, _lconfig_columnAlignMode = mempty
, _lconfig_alignmentLimit = mempty
, _lconfig_alignmentBreakOnMultiline = mempty
, _lconfig_hangingTypeSignature = mempty
, _lconfig_reformatModulePreamble = mempty
, _lconfig_allowSingleLineExportList = mempty
}
, _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors

View File

@ -53,7 +53,12 @@ data CLayoutConfig f = LayoutConfig
, _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for ","
-- when creating zero-indentation
-- multi-line list literals.
, _lconfig_importColumn :: f (Last Int)
, _lconfig_importColumn :: f (Last Int)
-- ^ for import statement layouting, column at which to align the
-- elements to be imported from a module.
, _lconfig_importAsColumn :: f (Last Int)
-- ^ for import statement layouting, column at which put the module's
-- "as" name (which also affects the positioning of the "as" keyword).
, _lconfig_altChooser :: f (Last AltChooser)
, _lconfig_columnAlignMode :: f (Last ColumnAlignMode)
, _lconfig_alignmentLimit :: f (Last Int)
@ -84,6 +89,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)

View File

@ -17,6 +17,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics
, docSeq
, docPar
, docNodeAnnKW
, docNodeMoveToKWDP
, docWrapNode
, docWrapNodePrior
, docWrapNodeRest
@ -30,6 +31,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics
, docAnnotationPrior
, docAnnotationKW
, docAnnotationRest
, docMoveToKWDP
, docNonBottomSpacing
, docSetParSpacing
, docForceParSpacing
@ -43,6 +45,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics
, appSep
, docCommaSep
, docParenLSep
, docParenR
, docTick
, spacifyDocs
, briDocMToPPM
@ -462,6 +465,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
@ -487,6 +497,9 @@ docCommaSep = appSep $ docLit $ Text.pack ","
docParenLSep :: ToBriDocM BriDocNumbered
docParenLSep = appSep $ docLit $ Text.pack "("
docParenR :: ToBriDocM BriDocNumbered
docParenR = docLit $ Text.pack ")"
docTick :: ToBriDocM BriDocNumbered
docTick = docLit $ Text.pack "'"
@ -499,6 +512,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

View File

@ -0,0 +1,145 @@
module Language.Haskell.Brittany.Internal.Layouters.IE
( layoutIE
, layoutLLIEs
, layoutAnnAndSepLLIEs
)
where
#include "prelude.inc"
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Config.Types
import RdrName (RdrName(..))
import GHC ( unLoc
, runGhc
, GenLocated(L)
, moduleNameString
, AnnKeywordId(..)
, Located
)
import HsSyn
import Name
import HsImpExp
import FieldLabel
import qualified FastString
import BasicTypes
import Language.Haskell.Brittany.Internal.Utils
#if MIN_VERSION_ghc(8,2,0)
prepareName :: LIEWrappedName name -> Located name
prepareName = ieLWrappedName
#else
prepareName :: Located name -> Located name
prepareName = id
#endif
layoutIE :: ToBriDoc IE
layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
IEVar _ -> ien
IEThingAbs _ -> ien
IEThingAll _ -> docSeq [ien, docLit $ Text.pack "(..)"]
IEThingWith _ (IEWildcard _) _ _ -> docSeq [ien, docLit $ Text.pack "(..)"]
IEThingWith _ _ ns _ -> do
hasComments <- hasAnyCommentsBelow lie
docAltFilter
[ ( not hasComments
, docSeq
$ [ien, docLit $ Text.pack "("]
++ intersperse docCommaSep (map nameDoc ns)
++ [docParenR]
)
, (otherwise
, docAddBaseY BrIndentRegular
$ docPar ien (layoutItems (splitFirstLast ns))
)
]
where
nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName
layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n]
layoutItems FirstLastEmpty =
docSetBaseY $
docLines [docSeq [docParenLSep, docWrapNodeRest lie docEmpty]
,docParenR
]
layoutItems (FirstLastSingleton n) =
docSetBaseY $ docLines
[docSeq [docParenLSep, docWrapNodeRest lie $ nameDoc n], docParenR]
layoutItems (FirstLast n1 nMs nN) =
docSetBaseY $ docLines $
[docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]]
++ map layoutItem nMs
++ [ docSeq [docCommaSep, docWrapNodeRest lie $ nameDoc nN]
, docParenR
]
IEModuleContents n -> docSeq
[ docLit $ Text.pack "module"
, docSeparator
, docLit . Text.pack . moduleNameString $ unLoc n
]
_ -> docEmpty
where ien = docLit =<< lrdrNameToTextAnn (ieName <$> lie)
-- Helper function to deal with Located lists of LIEs.
-- In particular this will also associate documentation
-- from the located list that actually belongs to the last IE.
-- It also adds docCommaSep to all but the first element
-- This configuration allows both vertical and horizontal
-- handling of the resulting list. Adding parens is
-- left to the caller since that is context sensitive
layoutAnnAndSepLLIEs
:: Located [LIE RdrName] -> ToBriDocM [ToBriDocM BriDocNumbered]
layoutAnnAndSepLLIEs llies@(L _ lies) = do
let makeIENode ie = docSeq [docCommaSep, ie]
let ieDocs = layoutIE <$> lies
ieCommaDocs <-
docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of
FirstLastEmpty -> []
FirstLastSingleton ie -> [ie]
FirstLast ie1 ieMs ieN ->
[ie1] ++ map makeIENode ieMs ++ [makeIENode ieN]
pure $ fmap pure ieCommaDocs -- returned shared nodes
-- Builds a complete layout for the given located
-- list of LIEs. The layout provides two alternatives:
-- (item, item, ..., item)
-- ( item
-- , item
-- ...
-- , item
-- )
-- If the llies contains comments the list will
-- always expand over multiple lines, even when empty:
-- () -- no comments
-- ( -- a comment
-- )
layoutLLIEs :: Bool -> Located [LIE RdrName] -> ToBriDocM BriDocNumbered
layoutLLIEs enableSingleline llies = do
ieDs <- layoutAnnAndSepLLIEs llies
hasComments <- hasAnyCommentsBelow llies
case ieDs of
[] -> docAltFilter
[ (not hasComments, docLit $ Text.pack "()")
, ( hasComments
, docPar (docSeq [docParenLSep, docWrapNodeRest llies docEmpty])
docParenR
)
]
(ieDsH:ieDsT) -> docAltFilter
[ ( not hasComments && enableSingleline
, docSeq
$ [docLit (Text.pack "(")]
++ (docForceSingleline <$> ieDs)
++ [docParenR]
)
, ( otherwise
, docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH])
$ docLines
$ ieDsT
++ [docParenR]
)
]

View File

@ -0,0 +1,147 @@
module Language.Haskell.Brittany.Internal.Layouters.Import (layoutImport) where
#include "prelude.inc"
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.IE
import Language.Haskell.Brittany.Internal.Config.Types
import RdrName ( RdrName(..) )
import GHC ( unLoc
, GenLocated(L)
, moduleNameString
, Located
)
import HsSyn
import Name
import FieldLabel
import qualified FastString
import BasicTypes
import Language.Haskell.Brittany.Internal.Utils
#if MIN_VERSION_ghc(8,2,0)
prepPkg :: SourceText -> String
prepPkg rawN = case rawN of
SourceText n -> n
-- This would be odd to encounter and the
-- result will most certainly be wrong
NoSourceText -> ""
#else
prepPkg :: String -> String
prepPkg = id
#endif
#if MIN_VERSION_ghc(8,2,0)
prepModName :: Located e -> e
prepModName = unLoc
#else
prepModName :: e -> e
prepModName = id
#endif
layoutImport :: ToBriDoc ImportDecl
layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of
ImportDecl _ (L _ modName) pkg src safe q False mas mllies -> do
importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack
importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
let
compact = indentPolicy == IndentPolicyLeft
modNameT = Text.pack $ moduleNameString modName
pkgNameT = Text.pack . prepPkg . sl_st <$> pkg
masT = Text.pack . moduleNameString . prepModName <$> mas
hiding = maybe False fst mllies
minQLength = length "import qualified "
qLengthReal =
let qualifiedPart = if q then length "qualified " else 0
safePart = if safe then length "safe " else 0
pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT
srcPart = if src then length "{-# SOURCE #-} " else 0
in length "import " + srcPart + safePart + qualifiedPart + pkgPart
qLength = max minQLength qLengthReal
-- Cost in columns of importColumn
asCost = length "as "
bindingCost = if hiding then length "hiding ( " else length "( "
nameCost = Text.length modNameT + qLength
importQualifiers = docSeq
[ appSep $ docLit $ Text.pack "import"
, if src then appSep $ docLit $ Text.pack "{-# SOURCE #-}" else docEmpty
, if safe then appSep $ docLit $ Text.pack "safe" else docEmpty
, if q then appSep $ docLit $ Text.pack "qualified" else docEmpty
, maybe docEmpty (appSep . docLit) pkgNameT
]
indentName =
if compact then id else docEnsureIndent (BrIndentSpecial qLength)
modNameD =
indentName $ appSep $ docLit modNameT
hidDoc =
if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty
importHead = docSeq [importQualifiers, modNameD]
bindingsD = case mllies of
Nothing -> docEmpty
Just (_, llies) -> do
hasComments <- hasAnyCommentsBelow llies
if compact
then docSeq [hidDoc, layoutLLIEs True llies]
else do
ieDs <- layoutAnnAndSepLLIEs llies
docWrapNodeRest llies $ case ieDs of
-- ..[hiding].( )
[] -> if hasComments
then docPar
(docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty])
docParenR
else docSeq [hidDoc, docParenLSep, docSeparator, docParenR]
-- ..[hiding].( b )
[ieD] -> docAltFilter
[ ( not hasComments
, docSeq
[ hidDoc
, docParenLSep
, docForceSingleline $ ieD
, docSeparator
, docParenR
]
)
, ( otherwise
, docPar
(docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD])
docParenR
)
]
-- ..[hiding].( b
-- , b'
-- )
(ieD:ieDs') ->
docPar (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]])
$ docLines
$ ieDs'
++ [docParenR]
bindingLine =
docEnsureIndent (BrIndentSpecial (importCol - bindingCost)) bindingsD
makeAsDoc asT =
docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT]
if compact
then
let asDoc = maybe docEmpty makeAsDoc masT
in docAlt
[ docForceSingleline $ docSeq [importHead, asDoc, bindingsD]
, docAddBaseY BrIndentRegular $
docPar (docSeq [importHead, asDoc]) bindingsD
]
else
case masT of
Just n | enoughRoom -> docLines [docSeq [importHead, asDoc], bindingLine]
| otherwise -> docLines [importHead, asDoc, bindingLine]
where
enoughRoom = nameCost < importAsCol - asCost
asDoc =
docEnsureIndent (BrIndentSpecial (importAsCol - asCost))
$ makeAsDoc n
Nothing | enoughRoom -> docSeq [importHead, bindingLine]
| otherwise -> docLines [importHead, bindingLine]
where enoughRoom = nameCost < importCol - bindingCost
_ -> docEmpty

View File

@ -0,0 +1,62 @@
module Language.Haskell.Brittany.Internal.Layouters.Module (layoutModule) where
#include "prelude.inc"
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.IE
import Language.Haskell.Brittany.Internal.Layouters.Import
import Language.Haskell.Brittany.Internal.Config.Types
import RdrName (RdrName(..))
import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..))
import HsSyn
import Name
import HsImpExp
import FieldLabel
import qualified FastString
import BasicTypes
import Language.Haskell.GHC.ExactPrint as ExactPrint
import Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import Language.Haskell.Brittany.Internal.Utils
layoutModule :: ToBriDoc HsModule
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
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 $ docAltFilter
[ (,) allowSingleLineExportList $ 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"
]
, (,) otherwise $ 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

View File

@ -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
@ -319,11 +321,16 @@ transformAlts briDoc =
BrIndentNone -> 0
BrIndentRegular -> indAmount
BrIndentSpecial i -> i
mSet $ acp { _acp_indentPrep = 0 -- TODO: i am not sure this is valid,
-- in general.
, _acp_indent = _acp_indent acp + indAdd
, _acp_line = _acp_line acp + indAdd
}
mSet $ acp
{ _acp_indentPrep = 0
-- TODO: i am not sure this is valid, in general.
, _acp_indent = _acp_indent acp + indAdd
, _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd)
-- we cannot use just _acp_line acp + indAdd because of the case
-- where there are multiple BDFEnsureIndents in the same line.
-- Then, the actual indentation is relative to the current
-- indentation, not the current cursor position.
}
r <- rec bd
acp' <- mGet
mSet $ acp' { _acp_indent = _acp_indent acp }
@ -455,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
@ -700,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

View File

@ -128,6 +128,7 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
BDAnnotationPrior{} -> Nothing
BDAnnotationKW{} -> Nothing
BDAnnotationRest{} -> Nothing
BDMoveToKWDP{} -> Nothing
BDEnsureIndent{} -> Nothing
BDSetParSpacing{} -> Nothing
BDForceParSpacing{} -> Nothing

View File

@ -178,6 +178,7 @@ data ColSig
| ColTuple
| ColTuples
| ColOpPrefix -- merge with ColList ? other stuff?
| ColImport
-- TODO
deriving (Eq, Ord, Data.Data.Data, Show)
@ -232,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
@ -277,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))
@ -310,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
@ -341,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
@ -376,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