diff --git a/.travis.yml b/.travis.yml index e1c64bf..50a0a71 100644 --- a/.travis.yml +++ b/.travis.yml @@ -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]}} diff --git a/ChangeLog.md b/ChangeLog.md index 05a7ea2..1b23e1e 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/README.md b/README.md index 3196b27..42e7fa5 100644 --- a/README.md +++ b/README.md @@ -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 diff --git a/brittany.cabal b/brittany.cabal index 173345e..9a65d37 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -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 diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 046c830..f986ad9 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -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] diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 680d6f1..3a5941c 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -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 ############################################################################### diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index c2290ba..5e4f52c 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -123,8 +123,8 @@ func = do #test list comprehension comment placement func = [ (thing, take 10 alts) --TODO: select best ones - | (thing, _got, alts@(_:_)) <- nosuchFooThing - , gast <- award + | (thing, _got, alts@(_ : _)) <- nosuchFooThing + , gast <- award ] #test if-then-else comment placement @@ -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) diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 938aca6..5567e68 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -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 diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index f4c4d6d..d1a27b3 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -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 ]") ) diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index 30eac3e..1ee5203 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 44264d4..c121eaf 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -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 = diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index baaca1f..ad991b5 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index d726d8a..f2530b0 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -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) diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index d0f481c..749804c 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 30e26c2..400d422 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -52,23 +52,39 @@ layoutSig lsig@(L _loc sig) = case sig of let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs typeDoc <- docSharedWrapper layoutType typ hasComments <- hasAnyCommentsBelow lsig - docAlt - $ [ docSeq - [ appSep $ docWrapNodeRest lsig $ docLit nameStr - , appSep $ docLit $ Text.pack "::" - , docForceSingleline typeDoc - ] - | not hasComments - ] - ++ [ docAddBaseY BrIndentRegular $ docPar - (docWrapNodeRest lsig $ docLit nameStr) - ( docCols - ColTyOpPrefix - [ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) $ typeDoc + 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 + , appSep $ docLit $ Text.pack "::" + , docForceSingleline typeDoc + ] + | not hasComments + ] + ++ [ docAddBaseY BrIndentRegular $ docPar + (docWrapNodeRest lsig $ docLit nameStr) + ( docCols + ColTyOpPrefix + [ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 3) $ typeDoc + ] + ) ] - ) - ] InlineSig name (InlinePragma _ spec _arity phaseAct conlike) -> docWrapNode lsig $ do nameStr <- lrdrNameToTextAnn name @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 2eb1863..807aad8 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -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 - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ return bindDoc - ] - , docSeq - [ appSep $ docLit $ Text.pack "in " - , docSetBaseY $ expDoc1 - ] + , docLines + [ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , ifIndentLeftElse docForceSingleline docSetBaseAndIndent + $ return bindDoc + ] + , docAddBaseY BrIndentRegular + $ docPar + (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) + ] ] - ) - , ( True - , docLines - [ docAddBaseY BrIndentRegular - $ docPar - (appSep $ docLit $ Text.pack "let") - (docSetBaseAndIndent $ return bindDoc) - , docAddBaseY BrIndentRegular - $ docPar - (appSep $ 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,36 +908,54 @@ 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 ] lineN = docSeq [ 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 */ diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index ebdd91d..51bb03a 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs index d34690c..88f2894 100644 --- a/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs @@ -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 diff --git a/stack-8.0.2.yaml b/stack-8.0.2.yaml new file mode 100644 index 0000000..ca6ad6a --- /dev/null +++ b/stack-8.0.2.yaml @@ -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: + - . diff --git a/stack.yaml b/stack.yaml index 539cd6d..74e27d2 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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: - .