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

Merge branch 'master' into import

pull/124/head
Lennart Spitzner 2018-03-11 17:43:16 +01:00
parent 98c93f0d63 e4dea87839
commit 41a60ce60f
20 changed files with 279 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.travis.yml
View File

@ -115,7 +115,7 @@ matrix:
#- env: BUILD=stack ARGS="--resolver lts-7"
# compiler: ": #stack 8.0.1"
# addons: {apt: {packages: [libgmp-dev]}}
- env: BUILD=stack ARGS="--resolver lts-8"
- env: BUILD=stack ARGS="--stack-yaml stack-8.0.2.yaml"
compiler: ": #stack 8.0.2"
addons: {apt: {packages: [libgmp-dev]}}

16
ChangeLog.md
View File

@ -1,5 +1,21 @@
# Revision history for brittany
## 0.9.0.1 -- February 2018
* Support `TupleSections` (thanks to Matthew Piziak)
* Bugfixes:
- Fix Shebang handling with stdin input (#92)
- Fix bug that effectively deleted strict/lazy matches (BangPatterns) (#116)
- Fix infix operator whitespace bug (#101, #114)
- Fix help command output and its layouting (#103)
- Fix crash when config dir does not exist yet (#115)
* Layouting changes:
- no space after opening non-tuple parenthesis even for multi-line case
- use spaces around infix operators (applies to sections and in pattern
matches)
- Let-in is layouted more flexibly in fewer lines, if possible
(thanks to Evan Borden)
## 0.9.0.0 -- December 2017
* Change default global config path (use XDG spec)

29
README.md
View File

@ -52,11 +52,12 @@ log the size of the input, but _not_ the full requests.)
# Other usage notes
- Supports GHC versions `8.0.*` and `8.2.*`.
- as of November'17, `brittany` is available on stackage nightly.
- included in stackage with lts>=10.0 (or nightlies dating to >=2017-11-15)
- config (file) documentation is lacking.
- some config values can not be configured via commandline yet.
- uses/creates user config file in `~/.config/brittany/config.yaml`;
also reads `brittany.yaml` in current dir if present.
also reads (the first) `brittany.yaml` found in current or parent
directories.
# Installation
@ -84,11 +85,11 @@ log the size of the input, but _not_ the full requests.)
- via `stack` using a sufficiently recent stackage snapshot (dated to >= 2017-11-15)
~~~~.sh
stack install brittany # --resolver=nightly-2017-11-15
stack install brittany # --resolver lts-10.0
~~~~
(alternatively, should nightlies be unreliable, or you want to use ghc-8.0 or something, then
cloning the repo and doing `stack install` will use an lts resolver.)
(earlier ltss did not include `brittany` yet, but the repo should contain a
`stack.yaml` that works with ghc-8.0.)
- on ArchLinux via [the britanny AUR package](https://aur.archlinux.org/packages/brittany/)
using `aura`:
@ -96,6 +97,22 @@ log the size of the input, but _not_ the full requests.)
aura -A brittany
~~~~
# Editor Integration
#### Sublime text
[In this gist](https://gist.github.com/lspitzner/097c33177248a65e7657f0c6d0d12075)
I have described a haskell setup that includes a shortcut to run brittany formatting.
#### VSCode
[This extension](https://marketplace.visualstudio.com/items?itemName=MaxGabriel.brittany)
connects commandline `brittany` to VSCode formatting API. Thanks to @MaxGabriel.
#### Via HIE
[haskell-ide-engine](https://github.com/haskell/haskell-ide-engine)
includes a `brittany` plugin that directly uses the brittany library.
Relevant for any editors that properly support the language-server-protocol.
#### Neovim / Vim 8
The [Neoformat](https://github.com/sbdchd/neoformat) plugin comes with support for
brittany built in.
# Usage
- Default mode of operation: Transform a single module, from `stdin` to `stdout`.
@ -143,8 +160,6 @@ a good amount of high-level documentation at
[the documentation index](doc/implementation/index.md)
Note that most development happens on the `dev` branch of this repository!
# License
Copyright (C) 2016-2017 Lennart Spitzner

6
brittany.cabal
View File

@ -1,5 +1,5 @@
name: brittany
version: 0.9.0.0
version: 0.9.0.1
synopsis: Haskell source code formatter
description: {
See <https://github.com/lspitzner/brittany/blob/master/README.md the README>.
@ -85,7 +85,7 @@ library {
{ base >=4.9 && <4.11
, ghc >=8.0.1 && <8.3
, ghc-paths >=0.1.0.9 && <0.2
, ghc-exactprint >=0.5.3.0 && <0.6
, ghc-exactprint >=0.5.6.0 && <0.5.7
, transformers >=0.5.2.0 && <0.6
, containers >=0.5.7.1 && <0.6
, mtl >=2.2.1 && <2.3
@ -97,7 +97,7 @@ library {
, pretty >=1.1.3.3 && <1.2
, bytestring >=0.10.8.1 && <0.11
, directory >=1.2.6.2 && <1.4
, butcher >=1.2 && <1.3
, butcher >=1.3 && <1.4
, yaml >=0.8.18 && <0.9
, aeson >=1.0.1.0 && <1.3
, extra >=1.4.10 && <1.7

25
src-brittany/Main.hs
View File

@ -82,9 +82,10 @@ helpDoc = PP.vcat $ List.intersperse
]
, parDocW
[ "This program is written carefully and contains safeguards to ensure"
, "the transformation does not change semantics (or the syntax tree at all)"
, "and that no comments are removed."
, "Nonetheless, this is a young project, and there will always be bugs."
, "the output is syntactically valid and that no comments are removed."
, "Nonetheless, this is a young project, and there will always be bugs,"
, "and ensuring that the transformation never changes semantics of the"
, "transformed source is currently not possible."
, "Please do check the output and do not let brittany override your large"
, "codebase without having backups."
]
@ -140,16 +141,16 @@ mainCmdParser helpDesc = do
""
["write-mode"]
"(display|inplace)"
Flag
{ _flag_help = Just $ PP.vcat
( flagHelp
( PP.vcat
[ PP.text "display: output for any input(s) goes to stdout"
, PP.text "inplace: override respective input file (without backup!)"
]
, _flag_default = Just Display
}
inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input haskell source files")
)
<> flagDefault Display
)
inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input/inout haskell source files")
reorderStop
desc <- peekCmdDesc
addCmdImpl $ void $ do
when printLicense $ do
print licenseDoc
@ -161,7 +162,7 @@ mainCmdParser helpDesc = do
putStrLn $ "There is NO WARRANTY, to the extent permitted by law."
System.Exit.exitSuccess
when printHelp $ do
liftIO $ print $ ppHelpShallow desc
liftIO $ putStrLn $ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } $ ppHelpShallow helpDesc
System.Exit.exitSuccess
let inputPaths = if null inputParams then [Nothing] else map Just inputParams
@ -281,7 +282,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
putErrorLn
$ "Error: detected unprocessed comments."
++ " The transformation output will most likely"
++ " not contain certain of the comments"
++ " not contain some of the comments"
++ " present in the input haskell source file."
putErrorLn $ "Affected are the following comments:"
unused `forM_` \case
@ -346,7 +347,7 @@ readConfigs cmdlineConfig configPaths = do
userConfigXdg <- readConfig userConfigPathXdg
let userConfig = userConfigSimple <|> userConfigXdg
when (Data.Maybe.isNothing userConfig) $ do
liftIO $ Directory.createDirectoryIfMissing False userBritPathXdg
liftIO $ Directory.createDirectoryIfMissing True userBritPathXdg
writeDefaultConfig userConfigPathXdg
-- rightmost has highest priority
pure $ [userConfig, localConfig]

11
src-literatetests/10-tests.blt
View File

@ -287,6 +287,10 @@ func = f
{-# INLINE CONLIKE [1] f #-}
f = id
#test noinline pragma 1
{-# NOINLINE func #-}
func :: Int
#test inline pragma 4
#pending this does not work with the compiler version we currently use yet (i think). should work with ghc-8.0.2.
func = f
@ -349,11 +353,14 @@ func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable
func (A a) = a
#test list constructor
func (x:xr) = x
func (x : xr) = x
#test some other constructor symbol
#pending
func (x:+:xr) = x
func (x :+: xr) = x
#test normal infix constructor
func (x `Foo` xr) = x
###############################################################################

21
src-literatetests/15-regressions.blt
View File

@ -123,7 +123,7 @@ func = do
#test list comprehension comment placement
func =
[ (thing, take 10 alts) --TODO: select best ones
| (thing, _got, alts@(_:_)) <- nosuchFooThing
| (thing, _got, alts@(_ : _)) <- nosuchFooThing
, gast <- award
]
@ -219,7 +219,7 @@ showPackageDetailedInfo pkginfo =
, entry
"Versions installed"
installedVersions
( altText
(altText
null
(if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]")
)
@ -367,9 +367,8 @@ runBrittany tabSize text = do
let
config' = staticDefaultConfig
config = config'
{ _conf_layout = (_conf_layout config') { _lconfig_indentAmount = coerce
tabSize
}
{ _conf_layout =
(_conf_layout config') { _lconfig_indentAmount = coerce tabSize }
, _conf_forward = forwardOptionsSyntaxExtsEnabled
}
parsePrintModule config text
@ -513,3 +512,15 @@ cs0 = 0 : [ c / Interval n | c <- cs | n <- [1..] ]
#test issue 70
{-# LANGUAGE TemplateHaskell #-}
deriveFromJSON (unPrefix "assignPost") ''AssignmentPost
#test issue 116
{-# LANGUAGE BangPatterns #-}
func = do
let !forced = some
pure ()
#test let-in-hanging
spanKey p q = case minViewWithKey q of
Just ((k, _), q') | p k ->
let (kas, q'') = spanKey p q' in ((k, a) : kas, q'')
_ -> ([], q)

1
src-literatetests/Main.hs
View File

@ -173,6 +173,7 @@ defaultTestConfig = Config
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
, _lconfig_alignmentLimit = coerce (30 :: Int)
, _lconfig_alignmentBreakOnMultiline = coerce True
, _lconfig_hangingTypeSignature = coerce False
}
, _conf_errorHandling = (_conf_errorHandling staticDefaultConfig)
{ _econf_omit_output_valid_check = coerce True

15
src-literatetests/tests-context-free.blt
View File

@ -366,11 +366,11 @@ func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable
func (A a) = a
#test list constructor
func (x:xr) = x
func (x : xr) = x
#test some other constructor symbol
#pending
func (x:+:xr) = x
func (x :+: xr) = x
###############################################################################
@ -510,6 +510,11 @@ func = (abc, def)
func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
, lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd)
#test let in on single line
foo =
let longIdentifierForShortValue = 1
in longIdentifierForShortValue + longIdentifierForShortValue
###############################################################################
@ -964,7 +969,7 @@ func
#test some indentation thingy
func =
( lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj
(lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj
$ abc
$ def
$ ghi
@ -993,7 +998,7 @@ func = do
#test list comprehension comment placement
func =
[ (thing, take 10 alts) --TODO: select best ones
| (thing, _got, alts@(_:_)) <- nosuchFooThing
| (thing, _got, alts@(_ : _)) <- nosuchFooThing
, gast <- award
]
@ -1090,7 +1095,7 @@ showPackageDetailedInfo pkginfo =
, entry
"Versions installed"
installedVersions
( altText
(altText
null
(if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]")
)

1
src-unittests/TestUtils.hs
View File

@ -55,6 +55,7 @@ defaultTestConfig = Config
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
, _lconfig_alignmentLimit = coerce (30 :: Int)
, _lconfig_alignmentBreakOnMultiline = coerce True
, _lconfig_hangingTypeSignature = coerce False
}
, _conf_errorHandling = (_conf_errorHandling staticDefaultConfig)
{ _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever

6
src/Language/Haskell/Brittany/Internal/Backend.hs
View File

@ -352,7 +352,11 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
-- maxZipper xs [] = xs
-- maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr
colAggregation :: [Int] -> Int
colAggregation xs = maximum [ x | x <- xs, x < minimum xs + alignMax ]
colAggregation [] = 0 -- this probably cannot happen the way we call
-- this function, because _cbs_map only ever
-- contains nonempty Seqs.
colAggregation xs = maximum [ x | x <- xs, x <= minimum xs + alignMax' ]
where alignMax' = max 0 alignMax
processedMap :: ColMap2
processedMap =

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

@ -63,6 +63,7 @@ staticDefaultConfig = Config
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
, _lconfig_alignmentLimit = coerce (30 :: Int)
, _lconfig_alignmentBreakOnMultiline = coerce True
, _lconfig_hangingTypeSignature = coerce False
}
, _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = coerce False
@ -104,7 +105,7 @@ configParser = do
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")
dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (commandline + file + defaults)")
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")
dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany")
dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast")
@ -118,9 +119,9 @@ configParser = do
dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent")
dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc")
outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible")
outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)")
wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors")
omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid; for dev on brittany")
omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)")
roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)")
@ -156,6 +157,7 @@ configParser = do
, _lconfig_columnAlignMode = mempty
, _lconfig_alignmentLimit = mempty
, _lconfig_alignmentBreakOnMultiline = mempty
, _lconfig_hangingTypeSignature = mempty
}
, _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors

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

@ -73,6 +73,17 @@ data CLayoutConfig f = LayoutConfig
-- short <- some more stuff
-- that requires two lines
-- loooooooong <- stuff
, _lconfig_hangingTypeSignature :: f (Last Bool)
-- Do not put "::" in a new line, and use hanging indentation for the
-- signature, i.e.:
-- func :: SomeLongStuff
-- -> SomeLongStuff
-- instead of the usual
-- func
-- :: SomeLongStuff
-- -> SomeLongStuff
-- As usual for hanging indentation, the result will be
-- context-sensitive (in the function name).
}
deriving (Generic)

16
src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
View File

@ -24,11 +24,17 @@ import qualified DynFlags as GHC
import qualified GHC as GHC hiding (parseModule)
import qualified Parser as GHC
import qualified SrcLoc as GHC
import qualified FastString as GHC
import qualified GHC as GHC hiding (parseModule)
import qualified Lexer as GHC
import qualified StringBuffer as GHC
import qualified Outputable as GHC
import RdrName ( RdrName(..) )
import HsSyn
import SrcLoc ( SrcSpan, Located )
import RdrName ( RdrName(..) )
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
@ -106,12 +112,12 @@ parseModuleFromString args fp dynCheck str =
$ ExceptT.throwE
$ "when parsing ghc flags: encountered warnings: "
++ show (warnings <&> \(L _ s) -> s)
x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1
either (\(span, err) -> ExceptT.throwE $ show span ++ ": " ++ err)
(\(a, m) -> pure (a, m, x))
$ ExactPrint.parseWith dflags1 fp GHC.parseModule str
dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1
let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str
case res of
Left (span, err) -> ExceptT.throwE $ show span ++ ": " ++ err
Right (a , m ) -> pure (a, m, dynCheckRes)
-----------
commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()
commentAnnFixTransformGlob ast = do

57
src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
View File

@ -52,6 +52,22 @@ layoutSig lsig@(L _loc sig) = case sig of
let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs
typeDoc <- docSharedWrapper layoutType typ
hasComments <- hasAnyCommentsBelow lsig
shouldBeHanging <- mAsk
<&> _conf_layout
.> _lconfig_hangingTypeSignature
.> confUnpack
if shouldBeHanging
then docSeq
[ appSep $ docWrapNodeRest lsig $ docLit nameStr
, docSetBaseY $ docLines
[ docCols
ColTyOpPrefix
[ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 3) $ typeDoc
]
]
]
else
docAlt
$ [ docSeq
[ appSep $ docWrapNodeRest lsig $ docLit nameStr
@ -78,7 +94,8 @@ layoutSig lsig@(L _loc sig) = case sig of
NoInline -> "NOINLINE "
EmptyInlineSpec -> "" -- i have no idea if this is correct.
let phaseStr = case phaseAct of
NeverActive -> "[] "
NeverActive -> "" -- not [] - for NOINLINE NeverActive is
-- in fact the default
AlwaysActive -> ""
ActiveBefore _ i -> "[~" ++ show i ++ "] "
ActiveAfter _ i -> "[" ++ show i ++ "] "
@ -176,16 +193,17 @@ layoutPatternBind
-> BriDocNumbered
-> LMatch RdrName (LHsExpr RdrName)
-> ToBriDocM BriDocNumbered
layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhss whereBinds))) = do
layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match fixityOrCtx pats _ (GRHSs grhss whereBinds))) = do
patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
let isInfix = isInfixMatch match
patDoc <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of
(Just idStr, p1:pr) | isInfix -> docCols
let mIdStr' = fixPatternBindIdentifier fixityOrCtx <$> mIdStr
patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of
(Just idStr, p1 : pr) | isInfix -> docCols
ColPatternsFuncInfix
( [appSep $ docForceSingleline p1, appSep $ docLit idStr]
++ (spacifyDocs $ docForceSingleline <$> pr)
)
(Just idStr, [] ) -> docLit idStr
(Just idStr, []) -> docLit idStr
(Just idStr, ps) ->
docCols ColPatternsFuncPrefix
$ appSep (docLit $ idStr)
@ -204,6 +222,28 @@ layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhs
mWhereDocs
hasComments
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
fixPatternBindIdentifier
:: HsMatchContext (NameOrRdrName RdrName) -> Text -> Text
fixPatternBindIdentifier ctx idStr = case ctx of
(FunRhs _ _ SrcLazy ) -> Text.cons '~' idStr
(FunRhs _ _ SrcStrict ) -> Text.cons '!' idStr
(FunRhs _ _ NoSrcStrict) -> idStr
(StmtCtxt ctx1 ) -> fixPatternBindIdentifier' ctx1
_ -> idStr
where
-- I have really no idea if this path ever occurs, but better safe than
-- risking another "drop bangpatterns" bugs.
fixPatternBindIdentifier' = \case
(PatGuard ctx1) -> fixPatternBindIdentifier ctx1 idStr
(ParStmtCtxt ctx1) -> fixPatternBindIdentifier' ctx1
(TransStmtCtxt ctx1) -> fixPatternBindIdentifier' ctx1
_ -> idStr
#else /* ghc-8.0 */
fixPatternBindIdentifier :: MatchFixity RdrName -> Text -> Text
fixPatternBindIdentifier _ x = x
#endif
layoutPatternBindFinal
:: Maybe Text
-> BriDocNumbered
@ -261,10 +301,13 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
]
let singleLineGuardsDoc guards = appSep $ case guards of
[] -> docEmpty
[g] -> docSeq [appSep $ docLit $ Text.pack "|", return g]
[g] -> docSeq
[appSep $ docLit $ Text.pack "|", docForceSingleline $ return g]
gs -> docSeq
$ [appSep $ docLit $ Text.pack "|"]
++ List.intersperse docCommaSep (return <$> gs)
++ (List.intersperse docCommaSep
(docForceSingleline . return <$> gs)
)
indentPolicy <- mAsk
<&> _conf_layout

94
src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
View File

@ -327,7 +327,7 @@ layoutExpr lexpr@(L _ expr) = do
]
, docSetBaseY $ docLines
[ docCols ColOpPrefix
[ docParenLSep
[ docLit $ Text.pack "("
, docAddBaseY (BrIndentSpecial 2) innerExpDoc
]
, docLit $ Text.pack ")"
@ -531,46 +531,49 @@ layoutExpr lexpr@(L _ expr) = do
HsLet binds exp1 -> do
expDoc1 <- docSharedWrapper layoutExpr exp1
mBindDocs <- layoutLocalBinds binds
-- this `docSetIndentLevel` might seem out of place, but is here due to
-- ghc-exactprint's DP handling of "let" in particular.
let
ifIndentLeftElse :: a -> a -> a
ifIndentLeftElse x y =
if indentPolicy == IndentPolicyLeft then x else y
-- this `docSetBaseAndIndent` might seem out of place (especially the
-- Indent part; setBase is necessary due to the use of docLines below),
-- but is here due to ghc-exactprint's DP handling of "let" in
-- particular.
-- Just pushing another indentation level is a straightforward approach
-- to making brittany idempotent, even though the result is non-optimal
-- if "let" is moved horizontally as part of the transformation, as the
-- comments before the first let item are moved horizontally with it.
docSetIndentLevel $ case mBindDocs of
Just [bindDoc] -> docAltFilter
[ ( True
, docSeq
docSetBaseAndIndent $ case mBindDocs of
Just [bindDoc] -> docAlt
[ docSeq
[ appSep $ docLit $ Text.pack "let"
, appSep $ docForceSingleline $ return bindDoc
, appSep $ docLit $ Text.pack "in"
, docForceSingleline $ expDoc1
]
)
, ( indentPolicy /= IndentPolicyLeft
, docLines
[ docAlt
[ docSeq
[ appSep $ docLit $ Text.pack "let"
, docSetBaseAndIndent $ return bindDoc
, ifIndentLeftElse docForceSingleline docSetBaseAndIndent
$ return bindDoc
]
, docSeq
[ appSep $ docLit $ Text.pack "in "
, docSetBaseY $ expDoc1
]
]
)
, ( True
, docLines
[ docAddBaseY BrIndentRegular
$ docPar
(appSep $ docLit $ Text.pack "let")
(docSetBaseAndIndent $ return bindDoc)
, docAddBaseY BrIndentRegular
$ docPar
(appSep $ docLit $ Text.pack "in")
(docLit $ Text.pack "let")
(docSetBaseAndIndent $ return bindDoc)
]
, docAlt
[ docSeq
[ appSep $ docLit $ Text.pack $ ifIndentLeftElse "in" "in "
, ifIndentLeftElse docForceSingleline docSetBaseAndIndent expDoc1
]
, docAddBaseY BrIndentRegular
$ docPar
(docLit $ Text.pack "in")
(docSetBaseY $ expDoc1)
]
)
]
]
Just bindDocs@(_:_) -> docAltFilter
--either
@ -732,6 +735,8 @@ layoutExpr lexpr@(L _ expr) = do
, docLit $ Text.pack "}"
]
RecordCon lname _ _ (HsRecFields fs@(_:_) Nothing) -> do
-- TODO: the layouter for RecordUpd is slightly more clever. Should
-- probably copy the approach from there.
let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname
((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do
fExpDoc <- if pun
@ -851,7 +856,7 @@ layoutExpr lexpr@(L _ expr) = do
Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc)
Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc)
docAltFilter
-- singleline
-- container { fieldA = blub, fieldB = blub }
[ ( True
, docSeq
[ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc
@ -869,7 +874,10 @@ layoutExpr lexpr@(L _ expr) = do
, docLit $ Text.pack "}"
]
)
-- wild-indentation block
-- hanging single-line fields
-- container { fieldA = blub
-- , fieldB = blub
-- }
, ( indentPolicy /= IndentPolicyLeft
, docSeq
[ docNodeAnnKW lexpr Nothing $ appSep rExprDoc
@ -880,7 +888,7 @@ layoutExpr lexpr@(L _ expr) = do
, case rF1e of
Just x -> docWrapNodeRest rF1f $ docSeq
[ appSep $ docLit $ Text.pack "="
, docForceSingleline $ x
, docForceSingleline x
]
Nothing -> docEmpty
]
@ -900,28 +908,45 @@ layoutExpr lexpr@(L _ expr) = do
in [line1] ++ lineR ++ [lineN]
]
)
-- strict indentation block
-- non-hanging with expressions placed to the right of the names
-- container
-- { fieldA = blub
-- , fieldB = potentially
-- multiline
-- }
, ( True
, docSetParSpacing
$ docAddBaseY BrIndentRegular
$ docPar
(docNodeAnnKW lexpr Nothing $ rExprDoc)
(docNonBottomSpacing $ docLines $ let
expressionWrapper = if indentPolicy == IndentPolicyLeft
then docForceParSpacing
else docSetBaseY
line1 = docCols ColRecUpdate
[ appSep $ docLit $ Text.pack "{"
, docWrapNodePrior rF1f $ appSep $ docLit $ rF1n
, docWrapNodeRest rF1f $ case rF1e of
Just x -> docSeq [ appSep $ docLit $ Text.pack "="
, docAddBaseY BrIndentRegular $ x
Just x -> docAlt
[ docSeq [ appSep $ docLit $ Text.pack "="
, expressionWrapper x
]
, docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "=") x
]
Nothing -> docEmpty
]
lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate
lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield
$ docCols ColRecUpdate
[ docCommaSep
, appSep $ docLit $ fText
, case fDoc of
Just x -> docSeq [ appSep $ docLit $ Text.pack "="
, docAddBaseY BrIndentRegular x
Just x -> docAlt
[ docSeq [ appSep $ docLit $ Text.pack "="
, expressionWrapper x
]
, docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "=") x
]
Nothing -> docEmpty
]
@ -929,7 +954,8 @@ layoutExpr lexpr@(L _ expr) = do
[ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty
, docLit $ Text.pack "}"
]
in [line1] ++ lineR ++ [lineN])
in [line1] ++ lineR ++ [lineN]
)
)
]
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */

6
src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
View File

@ -77,10 +77,10 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
return $ x1 Seq.<| xR
ConPatIn lname (InfixCon left right) -> do
-- a :< b -> expr
let nameDoc = lrdrNameToText lname
leftDoc <- colsWrapPat =<< layoutPat left
nameDoc <- lrdrNameToTextAnn lname
leftDoc <- appSep . colsWrapPat =<< layoutPat left
rightDoc <- colsWrapPat =<< layoutPat right
middle <- docLit nameDoc
middle <- appSep $ docLit nameDoc
return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc
ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do
-- Abc{} -> expr

3
src/Language/Haskell/Brittany/Internal/PreludeUtils.hs
View File

@ -46,6 +46,9 @@ traceFunctionWith name s1 s2 f x =
putStrErrLn :: String -> IO ()
putStrErrLn s = hPutStrLn stderr s
putStrErr :: String -> IO ()
putStrErr s = hPutStr stderr s
printErr :: Show a => a -> IO ()
printErr = putStrErrLn . show

12
stack-8.0.2.yaml Normal file
View File

@ -0,0 +1,12 @@
resolver: lts-9.0
extra-deps:
- monad-memo-0.4.1
- czipwith-1.0.0.0
- butcher-1.3.0.0
- data-tree-print-0.1.0.0
- deque-0.2
- ghc-exactprint-0.5.6.0
packages:
- .

9
stack.yaml
View File

@ -1,11 +1,4 @@
resolver: lts-9.0
extra-deps:
- monad-memo-0.4.1
- czipwith-1.0.0.0
- butcher-1.2.0.0
- data-tree-print-0.1.0.0
- deque-0.2
resolver: lts-10.0
packages:
- .