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

Merge branch 'dev'

pull/121/head 0.9.0.1
Lennart Spitzner 2018-02-14 17:30:25 +01:00
parent 779a23c380 bac69ba54f
commit 34036cbb74
21 changed files with 280 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
.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]}}
@ -178,7 +178,7 @@ before_install:
# echo 'jobs: $ncpus' >> $HOME/.cabal/config
#fi
- PKGNAME='brittany'
- JOBS='2'
- JOBS='1'
- |
function better_wait() {
date
@ -209,7 +209,7 @@ install:
set -ex
case "$BUILD" in
stack)
stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies
stack -j$JOBS --no-terminal --install-ghc $ARGS test --bench --only-dependencies
;;
cabal*)
cabal --version
@ -250,6 +250,8 @@ install:
cabal --version
travis_retry cabal update -v
echo 'packages: .' > cabal.project
echo 'package brittany' > cabal.project.local
echo ' ghc-options: -Werror' >> cabal.project.local
rm -f cabal.project.freeze
cabal new-build -j$JOBS --enable-test --enable-benchmarks --dep
cabal new-build -j$JOBS --disable-tests --disable-benchmarks --dep
@ -262,12 +264,12 @@ script:
set -ex
case "$BUILD" in
stack)
better_wait stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS"
better_wait stack -j$JOBS --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS -Werror"
;;
cabal)
if [ -f configure.ac ]; then autoreconf -i; fi
cabal configure --enable-tests --enable-benchmarks -v # -v2 provides useful information for debugging
better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" # this builds all libraries and executables (including tests/benchmarks)
better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS -Werror" # this builds all libraries and executables (including tests/benchmarks)
cabal test
;;
cabaldist)

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)

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>.
@ -82,7 +82,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
@ -94,7 +94,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

4
doc-svg-gen/doc-svg-gen.cabal
View File

@ -5,12 +5,12 @@ extra-source-files: ChangeLog.md
cabal-version: >=1.10
executable doc-svg-gen
buildable: True
buildable: False
main-is: Main.hs
-- other-modules:
-- other-extensions:
build-depends:
{ base >=4.9 && <4.10
{ base >=4.9 && <4.11
, text
, graphviz >=2999.19.0.0
}

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]

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

@ -349,11 +349,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
###############################################################################
@ -476,9 +479,23 @@ func = (`abc` 1)
#group tuples
###
#test 1
#test pair
func = (abc, def)
#test pair section left
func = (abc, )
#test pair section right
func = (, abc)
#test quintuple section long
myTupleSection =
( verylaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaargefirstelement
,
, verylaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaargethirdelement
,
)
#test 2
#pending
func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd

16
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 ]")
)
@ -513,3 +513,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
###############################################################################
@ -714,7 +719,7 @@ func
#test some indentation thingy
func =
( lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj
(lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj
$ abc
$ def
$ ghi
@ -743,7 +748,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
]
@ -840,7 +845,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

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

@ -61,6 +61,11 @@ import qualified GHC.LanguageExtensions.Type as GHC
--
-- Note that this function ignores/resets all config values regarding
-- debugging, i.e. it will never use `trace`/write to stderr.
--
-- Note that the ghc parsing function used internally currently is wrapped in
-- `mask_`, so cannot be killed easily. If you don't control the input, you
-- may wish to put some proper upper bound on the input's size as a timeout
-- won't do.
parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text)
parsePrintModule configRaw inputText = runExceptT $ do
let config = configRaw { _conf_debug = _conf_debug staticDefaultConfig }

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)

27
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
@ -37,6 +43,8 @@ import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint
import qualified Data.Generics as SYB
import Control.Exception
-- import Data.Generics.Schemes
@ -85,7 +93,14 @@ parseModuleFromString
-> String
-> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
parseModuleFromString args fp dynCheck str =
ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do
-- We mask here because otherwise using `throwTo` (i.e. for a timeout) will
-- produce nasty looking errors ("ghc panic"). The `mask_` makes it so we
-- cannot kill the parsing thread - not very nice. But i'll
-- optimistically assume that most of the time brittany uses noticable or
-- longer time, the majority of the time is not spend in parsing, but in
-- bridoc transformation stuff.
-- (reminder to update note on `parsePrintModule` if this changes.)
mask_ $ ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do
dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str
(dflags1, leftover, warnings) <- lift
$ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args)
@ -97,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

54
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
@ -176,16 +192,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 +221,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 +300,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

51
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 ")"
@ -341,9 +341,9 @@ layoutExpr lexpr@(L _ expr) = do
opDoc <- docSharedWrapper layoutExpr op
rightDoc <- docSharedWrapper layoutExpr right
docSeq [opDoc, docSeparator, rightDoc]
ExplicitTuple args boxity
| Just argExprs <- args `forM` (\case (L _ (Present e)) -> Just e; _ -> Nothing) -> do
argDocs <- docSharedWrapper layoutExpr `mapM` argExprs
ExplicitTuple args boxity -> do
let argExprs = fmap (\case (L _ (Present e)) -> Just e; (L _ (Missing PlaceHolder)) -> Nothing) args
argDocs <- docSharedWrapper (maybe docEmpty layoutExpr) `mapM` argExprs
hasComments <- hasAnyCommentsBelow lexpr
let (openLit, closeLit) = case boxity of
Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")")
@ -385,8 +385,6 @@ layoutExpr lexpr@(L _ expr) = do
end = closeLit
in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]
]
ExplicitTuple{} ->
unknownNodeError "ExplicitTuple|.." lexpr
HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do
cExpDoc <- docSharedWrapper layoutExpr cExp
binderDoc <- docLit $ Text.pack "->"
@ -533,6 +531,10 @@ layoutExpr lexpr@(L _ expr) = do
HsLet binds exp1 -> do
expDoc1 <- docSharedWrapper layoutExpr exp1
mBindDocs <- layoutLocalBinds binds
let
ifIndentLeftElse :: a -> a -> a
ifIndentLeftElse x y =
if indentPolicy == IndentPolicyLeft then x else y
-- this `docSetIndentLevel` might seem out of place, but is here due to
-- ghc-exactprint's DP handling of "let" in particular.
-- Just pushing another indentation level is a straightforward approach
@ -540,39 +542,36 @@ layoutExpr lexpr@(L _ expr) = do
-- 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
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

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

@ -24,12 +24,26 @@ import Language.Haskell.Brittany.Internal.Layouters.Type
-- | layouts patterns (inside function bindings, case alternatives, let
-- bindings or do notation). E.g. for input
-- > case computation of
-- > (warnings, Success a b) -> ..
-- This part ^^^^^^^^^^^^^^^^^^^^^^^ of the syntax tree is layouted by
-- 'layoutPat'. Similarly for
-- > func abc True 0 = []
-- ^^^^^^^^^^ this part
-- We will use `case .. of` as the imagined prefix to the examples used in
-- the different cases below.
layoutPat :: ToBriDocC (Pat RdrName) (Seq BriDocNumbered)
layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_"
-- _ -> expr
VarPat n -> fmap Seq.singleton $ docLit $ lrdrNameToText n
-- abc -> expr
LitPat lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit
-- 0 -> expr
ParPat inner -> do
-- (nestedpat) -> expr
left <- docLit $ Text.pack "("
right <- docLit $ Text.pack ")"
innerDocs <- colsWrapPat =<< layoutPat inner
@ -49,6 +63,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
-- xN' <- docSeq [return xN, docLit $ Text.pack ")"]
-- return $ (x1' Seq.<| middle) Seq.|> xN'
ConPatIn lname (PrefixCon args) -> do
-- Abc a b c -> expr
let nameDoc = lrdrNameToText lname
argDocs <- layoutPat `mapM` args
if null argDocs
@ -61,15 +76,19 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
$ fmap colsWrapPat argDocs
return $ x1 Seq.<| xR
ConPatIn lname (InfixCon left right) -> do
let nameDoc = lrdrNameToText lname
leftDoc <- colsWrapPat =<< layoutPat left
-- a :< b -> expr
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
let t = lrdrNameToText lname
fmap Seq.singleton $ docLit $ t <> Text.pack "{}"
ConPatIn lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do
-- Abc { a = locA, b = locB, c = locC } -> expr1
-- Abc { a, b, c } -> expr2
let t = lrdrNameToText lname
fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do
fExpDoc <- if pun
@ -91,12 +110,14 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
, docLit $ Text.pack "}"
]
ConPatIn lname (RecCon (HsRecFields [] (Just 0))) -> do
-- Abc { .. } -> expr
let t = lrdrNameToText lname
fmap Seq.singleton $ docSeq
[ appSep $ docLit t
, docLit $ Text.pack "{..}"
]
ConPatIn lname (RecCon (HsRecFields fs@(_:_) (Just dotdoti))) | dotdoti == length fs -> do
-- Abc { a = locA, .. }
let t = lrdrNameToText lname
fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do
fExpDoc <- if pun
@ -117,16 +138,20 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
, docLit $ Text.pack "..}"
]
TuplePat args boxity _ -> do
-- (nestedpat1, nestedpat2, nestedpat3) -> expr
-- (#nestedpat1, nestedpat2, nestedpat3#) -> expr
case boxity of
Boxed -> wrapPatListy args "(" ")"
Unboxed -> wrapPatListy args "(#" "#)"
AsPat asName asPat -> do
-- bind@nestedpat -> expr
wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@")
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
SigPatIn pat1 (HsWC _ (HsIB _ ty1 _)) -> do
#else /* ghc-8.0 */
SigPatIn pat1 (HsIB _ (HsWC _ _ ty1)) -> do
#endif
-- i :: Int -> expr
patDocs <- layoutPat pat1
tyDoc <- docSharedWrapper layoutType ty1
case Seq.viewr patDocs of
@ -146,12 +171,17 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
]
return $ xR Seq.|> xN'
ListPat elems _ _ ->
-- [] -> expr1
-- [nestedpat1, nestedpat2, nestedpat3] -> expr2
wrapPatListy elems "[" "]"
BangPat pat1 -> do
-- !nestedpat -> expr
wrapPatPrepend pat1 (docLit $ Text.pack "!")
LazyPat pat1 -> do
-- ~nestedpat -> expr
wrapPatPrepend pat1 (docLit $ Text.pack "~")
NPat llit@(L _ (OverLit olit _ _ _)) mNegative _ _ -> do
-- -13 -> expr
litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc olit
negDoc <- docLit $ Text.pack "-"
pure $ case mNegative of

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:
- .