diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,10 +1,27 @@ # 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) Existing config should still be respected, so this should not break compatibility +* Support per-project config * ! Slight rework of the commandline interface: - Support multiple inputs and outputs - Support inplace-transformation for multiple files via diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -43,14 +43,21 @@ accidentally quadratic sub-algorithm); noticable for inputs with >1k loc.~~ (fixed in `0.8.0.3`) +## Try without Installing + +You can [paste haskell code over here](https://hexagoxel.de/brittany/) +to test how it gets formatted by brittany. (Rg. privacy: the server does +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 `~/.brittany/config.yaml`; - also reads `brittany.yaml` in current dir if present. +- uses/creates user config file in `~/.config/brittany/config.yaml`; + also reads (the first) `brittany.yaml` found in current or parent + directories. # Installation @@ -75,23 +82,52 @@ cp `./find dist-newstyle/build/ -type f -name brittany` $HOME/.cabal/bin/ ~~~~ -- via `stack` +- via `stack` using a sufficiently recent stackage snapshot (dated to >= 2017-11-15) ~~~~.sh - git clone https://github.com/lspitzner/brittany.git - cd brittany - stack install + stack install brittany # --resolver lts-10.0 ~~~~ + (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`: + ~~~~.sh + 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 @MaxGarbriel. +#### 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 -- Currently one mode of operation: Transform a single module. By default read - from `stdin` and written to `stdout`, but commandline arguments allow to - read/write from/to files. +- Default mode of operation: Transform a single module, from `stdin` to `stdout`. + Can pass one or multiple files as input, and there is a flag to override them + in place instead of using `stdout` (since 0.9.0.0). So: + + ~~~~ .sh + brittany # stdin -> stdout + brittany mysource.hs # ./mysource.hs -> stdout + brittany --write-mode=inplace *.hs # apply formatting to all ./*.hs inplace + ~~~~ + - For stdin/stdout usage it makes sense to enable certain syntactic extensions by default, i.e. to add something like this to your - `~/.brittany/config.yaml` (execute `brittany` once to create default): + `~/.config/brittany/config.yaml` (execute `brittany` once to create default): ~~~~ conf_forward: diff --git a/brittany.cabal b/brittany.cabal --- 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 . @@ -82,7 +82,7 @@ { 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 @@ , 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 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -82,9 +82,10 @@ ] , 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 @@ "" ["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 @@ 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 @@ 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 @@ 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 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -349,13 +349,16 @@ 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,8 +479,22 @@ #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 diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -123,8 +123,8 @@ #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 @@ , entry "Versions installed" installedVersions - ( altText + (altText null (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]") ) @@ -513,3 +513,15 @@ #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 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -173,6 +173,7 @@ , _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 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -366,11 +366,11 @@ 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,8 +510,13 @@ func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd) +#test let in on single line +foo = + let longIdentifierForShortValue = 1 + in longIdentifierForShortValue + longIdentifierForShortValue + ############################################################################### ############################################################################### ############################################################################### @@ -714,7 +719,7 @@ #test some indentation thingy func = - ( lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj + (lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj $ abc $ def $ ghi @@ -743,7 +748,7 @@ #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 @@ , 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 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -55,6 +55,7 @@ , _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.hs b/src/Language/Haskell/Brittany/Internal.hs --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -61,6 +61,11 @@ -- -- 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 } diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -352,7 +352,11 @@ -- 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 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -63,6 +63,7 @@ , _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 @@ 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 @@ 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 @@ , _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 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -73,6 +73,17 @@ -- 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 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -24,11 +24,17 @@ 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.Delta as ExactPrint import qualified Data.Generics as SYB + +import Control.Exception -- import Data.Generics.Schemes @@ -85,7 +93,14 @@ -> 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 @@ $ 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 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -52,23 +52,39 @@ 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 @@ -176,16 +192,17 @@ -> 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 @@ 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 @@ ] 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 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -327,7 +327,7 @@ ] , docSetBaseY $ docLines [ docCols ColOpPrefix - [ docParenLSep + [ docLit $ Text.pack "(" , docAddBaseY (BrIndentSpecial 2) innerExpDoc ] , docLit $ Text.pack ")" @@ -341,9 +341,9 @@ 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 @@ 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 @@ 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 @@ -- 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 - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , 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") - (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) + ] ] - ) ] Just bindDocs@(_:_) -> docAltFilter --either diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -24,12 +24,26 @@ +-- | 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 @@ -- 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 @@ $ 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 @@ , 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 @@ , 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 @@ ] 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 diff --git a/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs --- a/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs @@ -46,6 +46,9 @@ putStrErrLn :: String -> IO () putStrErrLn s = hPutStrLn stderr s +putStrErr :: String -> IO () +putStrErr s = hPutStr stderr s + printErr :: Show a => a -> IO () printErr = putStrErrLn . show