brittany 0.12.1.1 → 0.12.2.0
raw patch · 33 files changed
+2410/−965 lines, 33 filesdep −neat-interpolationdep ~aesondep ~butcherdep ~bytestringnew-uploader
Dependencies removed: neat-interpolation
Dependency ranges changed: aeson, butcher, bytestring, cmdargs, containers, czipwith, deepseq, directory, extra, ghc, ghc-boot-th, ghc-exactprint, ghc-paths, monad-memo, mtl, multistate, pretty, safe, semigroups, strict, syb, text, transformers, uniplate, unsafe, yaml
Files
- ChangeLog.md +18/−3
- README.md +1/−1
- brittany.cabal +8/−58
- src-brittany/Main.hs +2/−465
- src-literatetests/10-tests.blt +327/−7
- src-literatetests/14-extensions.blt +84/−0
- src-literatetests/15-regressions.blt +121/−8
- src-literatetests/30-tests-context-free.blt +54/−6
- src-literatetests/Main.hs +100/−69
- src-unittests/AsymptoticPerfTests.hs +0/−2
- src-unittests/TestMain.hs +0/−2
- src-unittests/TestUtils.hs +3/−1
- src/Language/Haskell/Brittany/Internal.hs +63/−56
- src/Language/Haskell/Brittany/Internal/Backend.hs +35/−26
- src/Language/Haskell/Brittany/Internal/BackendUtils.hs +26/−13
- src/Language/Haskell/Brittany/Internal/Config.hs +99/−100
- src/Language/Haskell/Brittany/Internal/Config/Types.hs +15/−1
- src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +1/−0
- src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +1/−1
- src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +63/−14
- src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +527/−0
- src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +169/−43
- src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +26/−17
- src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +14/−7
- src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +7/−4
- src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +4/−1
- src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +51/−8
- src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +28/−9
- src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +1/−1
- src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +2/−0
- src/Language/Haskell/Brittany/Internal/Types.hs +62/−42
- src/Language/Haskell/Brittany/Internal/Utils.hs +14/−0
- src/Language/Haskell/Brittany/Main.hs +484/−0
ChangeLog.md view
@@ -1,5 +1,20 @@ # Revision history for brittany +## 0.12.2.0 -- November 2020++* #207: Fix newtype indent in associated type family.+* #231: Improve comments-affecting-layout behaviour for tuples.+* #259: Data declaration for newtype and records. Thanks @eborden!+* #263: Fix non-idempotent newlines with comment + where.+* #273: Error handling.+* #281: Fix moving comment in export list (haddock header).+* #286: Fix comments in instance/type instances.+* #287: Add support for pattern synonyms. Thanks @RaoulHC!+* #293: Expose main function as a module. Thanks @soareschen!+* #303: Readme: Supports 8.8. Thanks @andys8!+* #311: Allows aeson-1.5.*. Thanks @jkachmar!+* #313: Nondecreasing export list formatting. Thanks @expipiplus1!+ ## 0.12.1.1 -- December 2019 * Bugfixes:@@ -90,11 +105,11 @@ multiline-comments are supported too, although the specification must still be a single line. E.g.- + > "{- brittany --columns 50 -}"- + CONFIG is either:- + 1) one or more flags in the form of what brittany accepts on the commandline, e.g. "--columns 50", or 2) one or more specifications in the form of what brittany
README.md view
@@ -48,7 +48,7 @@ # Other usage notes -- Supports GHC versions `8.0`, `8.2`, `8.4`, `8.6`.+- Supports GHC versions `8.0`, `8.2`, `8.4`, `8.6`, `8.8`. - 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.
brittany.cabal view
@@ -1,5 +1,5 @@ name: brittany-version: 0.12.1.1+version: 0.12.2.0 synopsis: Haskell source code formatter description: { See <https://github.com/lspitzner/brittany/blob/master/README.md the README>.@@ -53,6 +53,7 @@ srcinc exposed-modules: { Language.Haskell.Brittany+ Language.Haskell.Brittany.Main Language.Haskell.Brittany.Internal Language.Haskell.Brittany.Internal.Prelude Language.Haskell.Brittany.Internal.PreludeUtils@@ -77,6 +78,7 @@ Language.Haskell.Brittany.Internal.Layouters.IE Language.Haskell.Brittany.Internal.Layouters.Import Language.Haskell.Brittany.Internal.Layouters.Module+ Language.Haskell.Brittany.Internal.Layouters.DataDecl Language.Haskell.Brittany.Internal.Transformations.Alt Language.Haskell.Brittany.Internal.Transformations.Floating Language.Haskell.Brittany.Internal.Transformations.Par@@ -99,15 +101,14 @@ , text >=1.2 && <1.3 , multistate >=0.7.1.1 && <0.9 , syb >=0.6 && <0.8- , neat-interpolation >=0.3.2 && <0.4 , data-tree-print , pretty >=1.1.3.3 && <1.2 , bytestring >=0.10.8.1 && <0.11 , directory >=1.2.6.2 && <1.4 , butcher >=1.3.1 && <1.4 , yaml >=0.8.18 && <0.12- , aeson >=1.0.1.0 && <1.5- , extra >=1.4.10 && <1.7+ , aeson >=1.0.1.0 && <1.6+ , extra >=1.4.10 && <1.8 , uniplate >=1.6.12 && <1.7 , strict >=0.3.2 && <0.4 , monad-memo >=0.4.1 && <0.6@@ -145,61 +146,12 @@ buildable: True } main-is: Main.hs- other-modules: {- Paths_brittany- }- -- other-extensions:+ hs-source-dirs: src-brittany build-depends:- { brittany- , base- , ghc- , ghc-paths- , ghc-exactprint- , transformers- , containers- , mtl- , text- , multistate- , syb- , neat-interpolation- , data-tree-print- , pretty- , bytestring- , directory- , butcher- , yaml- , aeson- , extra- , uniplate- , strict- , monad-memo- , unsafe- , safe- , deepseq- , semigroups- , cmdargs- , czipwith- , ghc-boot-th- , filepath >=1.4.1.0 && <1.5+ { base+ , brittany }- hs-source-dirs: src-brittany- include-dirs: srcinc default-language: Haskell2010- default-extensions: {- CPP-- NoImplicitPrelude-- GADTs-- FlexibleContexts- FlexibleInstances- ScopedTypeVariables- MonadComprehensions- LambdaCase- MultiWayIf- KindSignatures- } ghc-options: { -Wall -fno-spec-constr@@ -229,7 +181,6 @@ , text , multistate , syb- , neat-interpolation , data-tree-print , pretty , bytestring@@ -301,7 +252,6 @@ , text , multistate , syb- , neat-interpolation , data-tree-print , pretty , bytestring
src-brittany/Main.hs view
@@ -1,469 +1,6 @@-{-# LANGUAGE DataKinds #-}- module Main where ---#include "prelude.inc"---- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 }-import qualified Language.Haskell.GHC.ExactPrint as ExactPrint-import qualified Language.Haskell.GHC.ExactPrint.Annotate- as ExactPrint.Annotate-import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types-import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers-import qualified Data.Map as Map-import qualified Data.Monoid--import GHC ( GenLocated(L) )-import Outputable ( Outputable(..)- , showSDocUnsafe- )--import Text.Read ( Read(..) )-import qualified Text.ParserCombinators.ReadP as ReadP-import qualified Text.ParserCombinators.ReadPrec as ReadPrec-import qualified Data.Text.Lazy.Builder as Text.Builder--import Control.Monad ( zipWithM )-import Data.CZipWith--import qualified Debug.Trace as Trace--import Language.Haskell.Brittany.Internal.Types-import Language.Haskell.Brittany.Internal-import Language.Haskell.Brittany.Internal.Config-import Language.Haskell.Brittany.Internal.Config.Types-import Language.Haskell.Brittany.Internal.Utils-import Language.Haskell.Brittany.Internal.Obfuscation--import qualified Text.PrettyPrint as PP--import DataTreePrint-import UI.Butcher.Monadic--import qualified System.Exit-import qualified System.Directory as Directory-import qualified System.FilePath.Posix as FilePath--import qualified DynFlags as GHC-import qualified GHC.LanguageExtensions.Type as GHC--import Paths_brittany----data WriteMode = Display | Inplace--instance Read WriteMode where- readPrec = val "display" Display <|> val "inplace" Inplace- where val iden v = ReadPrec.lift $ ReadP.string iden >> return v--instance Show WriteMode where- show Display = "display"- show Inplace = "inplace"-+import qualified Language.Haskell.Brittany.Main as BrittanyMain main :: IO ()-main = mainFromCmdParserWithHelpDesc mainCmdParser--helpDoc :: PP.Doc-helpDoc = PP.vcat $ List.intersperse- (PP.text "")- [ parDocW- [ "Reformats one or more haskell modules."- , "Currently affects only the module head (imports/exports), type"- , "signatures and function bindings;"- , "everything else is left unmodified."- , "Based on ghc-exactprint, thus (theoretically) supporting all"- , "that ghc does."- ]- , parDoc $ "Example invocations:"- , PP.hang (PP.text "") 2 $ PP.vcat- [ PP.text "brittany"- , PP.nest 2 $ PP.text "read from stdin, output to stdout"- ]- , PP.hang (PP.text "") 2 $ PP.vcat- [ PP.text "brittany --indent=4 --write-mode=inplace *.hs"- , PP.nest 2 $ PP.vcat- [ PP.text "run on all modules in current directory (no backup!)"- , PP.text "4 spaces indentation"- ]- ]- , parDocW- [ "This program is written carefully and contains safeguards to ensure"- , "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."- ]- , parDoc $ "There is NO WARRANTY, to the extent permitted by law."- , parDocW- [ "This program is free software released under the AGPLv3."- , "For details use the --license flag."- ]- , parDoc $ "See https://github.com/lspitzner/brittany"- , parDoc- $ "Please report bugs at"- ++ " https://github.com/lspitzner/brittany/issues"- ]--licenseDoc :: PP.Doc-licenseDoc = PP.vcat $ List.intersperse- (PP.text "")- [ parDoc $ "Copyright (C) 2016-2019 Lennart Spitzner"- , parDoc $ "Copyright (C) 2019 PRODA LTD"- , parDocW- [ "This program is free software: you can redistribute it and/or modify"- , "it under the terms of the GNU Affero General Public License,"- , "version 3, as published by the Free Software Foundation."- ]- , parDocW- [ "This program is distributed in the hope that it will be useful,"- , "but WITHOUT ANY WARRANTY; without even the implied warranty of"- , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the"- , "GNU Affero General Public License for more details."- ]- , parDocW- [ "You should have received a copy of the GNU Affero General Public"- , "License along with this program. If not, see"- , "<http://www.gnu.org/licenses/>."- ]- ]---mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) ()-mainCmdParser helpDesc = do- addCmdSynopsis "haskell source pretty printer"- addCmdHelp $ helpDoc- -- addCmd "debugArgs" $ do- addHelpCommand helpDesc- addCmd "license" $ addCmdImpl $ print $ licenseDoc- -- addButcherDebugCommand- reorderStart- printHelp <- addSimpleBoolFlag "h" ["help"] mempty- printVersion <- addSimpleBoolFlag "" ["version"] mempty- printLicense <- addSimpleBoolFlag "" ["license"] mempty- noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty- configPaths <- addFlagStringParams ""- ["config-file"]- "PATH"- (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?- cmdlineConfig <- cmdlineConfigParser- suppressOutput <- addSimpleBoolFlag- ""- ["suppress-output"]- (flagHelp $ parDoc- "suppress the regular output, i.e. the transformed haskell source"- )- _verbosity <- addSimpleCountFlag- "v"- ["verbose"]- (flagHelp $ parDoc "[currently without effect; TODO]")- checkMode <- addSimpleBoolFlag- "c"- ["check-mode"]- (flagHelp- (PP.vcat- [ PP.text "check for changes but do not write them out"- , PP.text "exits with code 0 if no changes necessary, 1 otherwise"- ]- )- )- writeMode <- addFlagReadParam- ""- ["write-mode"]- "(display|inplace)"- ( flagHelp- (PP.vcat- [ PP.text "display: output for any input(s) goes to stdout"- , PP.text "inplace: override respective input file (without backup!)"- ]- )- Data.Monoid.<> flagDefault Display- )- inputParams <- addParamNoFlagStrings- "PATH"- (paramHelpStr "paths to input/inout haskell source files")- reorderStop- addCmdImpl $ void $ do- when printLicense $ do- print licenseDoc- System.Exit.exitSuccess- when printVersion $ do- do- putStrLn $ "brittany version " ++ showVersion version- putStrLn $ "Copyright (C) 2016-2019 Lennart Spitzner"- putStrLn $ "Copyright (C) 2019 PRODA LTD"- putStrLn $ "There is NO WARRANTY, to the extent permitted by law."- System.Exit.exitSuccess- when printHelp $ do- 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- let outputPaths = case writeMode of- Display -> repeat Nothing- Inplace -> inputPaths-- configsToLoad <- liftIO $ if null configPaths- then- maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath)- else pure configPaths-- config <-- runMaybeT- (if noUserConfig- then readConfigs cmdlineConfig configsToLoad- else readConfigsWithUserConfig cmdlineConfig configsToLoad- )- >>= \case- Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53)- Just x -> return x- when (config & _conf_debug & _dconf_dump_config & confUnpack)- $ trace (showConfigYaml config)- $ return ()-- results <- zipWithM- (coreIO putStrErrLn config (suppressOutput || checkMode))- inputPaths- outputPaths-- if checkMode- then when (any (== Changes) (Data.Either.rights results))- $ System.Exit.exitWith (System.Exit.ExitFailure 1)- else case results of- xs | all Data.Either.isRight xs -> pure ()- [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x)- _ -> System.Exit.exitWith (System.Exit.ExitFailure 1)---data ChangeStatus = Changes | NoChanges- deriving (Eq)---- | The main IO parts for the default mode of operation, and after commandline--- and config stuff is processed.-coreIO- :: (String -> IO ()) -- ^ error output function. In parallel operation, you- -- may want serialize the different outputs and- -- consequently not directly print to stderr.- -> Config -- ^ global program config.- -> Bool -- ^ whether to supress output (to stdout). Purely IO flag, so- -- currently not part of program config.- -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing.- -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing.- -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status.-coreIO putErrorLnIO config suppressOutput inputPathM outputPathM =- ExceptT.runExceptT $ do- let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO ()- let ghcOptions = config & _conf_forward & _options_ghc & runIdentity- -- there is a good of code duplication between the following code and the- -- `pureModuleTransform` function. Unfortunately, there are also a good- -- amount of slight differences: This module is a bit more verbose, and- -- it tries to use the full-blown `parseModule` function which supports- -- CPP (but requires the input to be a file..).- let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack- -- the flag will do the following: insert a marker string- -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with- -- "#include" before processing (parsing) input; and remove that marker- -- string from the transformation output.- -- The flag is intentionally misspelled to prevent clashing with- -- inline-config stuff.- let hackAroundIncludes =- config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack- let exactprintOnly = viaGlobal || viaDebug- where- viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack- viaDebug =- config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack-- let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags- then case cppMode of- CPPModeAbort -> do- return $ Left "Encountered -XCPP. Aborting."- CPPModeWarn -> do- putErrorLnIO- $ "Warning: Encountered -XCPP."- ++ " Be warned that -XCPP is not supported and that"- ++ " brittany cannot check that its output is syntactically"- ++ " valid in its presence."- return $ Right True- CPPModeNowarn -> return $ Right True- else return $ Right False- (parseResult, originalContents) <- case inputPathM of- Nothing -> do- -- TODO: refactor this hack to not be mixed into parsing logic- let hackF s = if "#include" `isPrefixOf` s- then "-- BRITANY_INCLUDE_HACK " ++ s- else s- let hackTransform = if hackAroundIncludes && not exactprintOnly- then List.intercalate "\n" . fmap hackF . lines'- else id- inputString <- liftIO $ System.IO.hGetContents System.IO.stdin- parseRes <- liftIO $ parseModuleFromString ghcOptions- "stdin"- cppCheckFunc- (hackTransform inputString)- return (parseRes, Text.pack inputString)- Just p -> liftIO $ do- parseRes <- parseModule ghcOptions p cppCheckFunc- inputText <- Text.IO.readFile p- -- The above means we read the file twice, but the- -- GHC API does not really expose the source it- -- read. Should be in cache still anyways.- --- -- We do not use TextL.IO.readFile because lazy IO is evil.- -- (not identical -> read is not finished ->- -- handle still open -> write below crashes - evil.)- return (parseRes, inputText)- case parseResult of- Left left -> do- putErrorLn "parse error:"- putErrorLn $ show left- ExceptT.throwE 60- Right (anns, parsedSource, hasCPP) -> do- (inlineConf, perItemConf) <-- case- extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)- of- Left (err, input) -> do- putErrorLn $ "Error: parse error in inline configuration:"- putErrorLn err- putErrorLn $ " in the string \"" ++ input ++ "\"."- ExceptT.throwE 61- Right c -> -- trace (showTree c) $- pure c- let moduleConf = cZipWith fromOptionIdentity config inlineConf- when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do- let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource- trace ("---- ast ----\n" ++ show val) $ return ()- (errsWarns, outSText) <- do- if exactprintOnly- then do- pure ([], Text.pack $ ExactPrint.exactPrint parsedSource anns)- else do- let omitCheck =- moduleConf- & _conf_errorHandling- .> _econf_omit_output_valid_check- .> confUnpack- (ews, outRaw) <- if hasCPP || omitCheck- then return- $ pPrintModule moduleConf perItemConf anns parsedSource- else liftIO $ pPrintModuleAndCheck moduleConf- perItemConf- anns- parsedSource- let hackF s = fromMaybe s $ TextL.stripPrefix- (TextL.pack "-- BRITANY_INCLUDE_HACK ")- s- let out = TextL.toStrict $ if hackAroundIncludes- then- TextL.intercalate (TextL.pack "\n")- $ fmap hackF- $ TextL.splitOn (TextL.pack "\n") outRaw- else outRaw- out' <- if moduleConf & _conf_obfuscate & confUnpack- then lift $ obfuscate out- else pure out- pure $ (ews, out')- let customErrOrder ErrorInput{} = 4- customErrOrder LayoutWarning{} = 0 :: Int- customErrOrder ErrorOutputCheck{} = 1- customErrOrder ErrorUnusedComment{} = 2- customErrOrder ErrorUnknownNode{} = 3- customErrOrder ErrorMacroConfig{} = 5- when (not $ null errsWarns) $ do- let groupedErrsWarns =- Data.List.Extra.groupOn customErrOrder- $ List.sortOn customErrOrder- $ errsWarns- groupedErrsWarns `forM_` \case- (ErrorOutputCheck{} : _) -> do- putErrorLn- $ "ERROR: brittany pretty printer"- ++ " returned syntactically invalid result."- (ErrorInput str : _) -> do- putErrorLn $ "ERROR: parse error: " ++ str- uns@(ErrorUnknownNode{} : _) -> do- putErrorLn $ "ERROR: encountered unknown syntactical constructs:"- uns `forM_` \case- ErrorUnknownNode str ast@(L loc _) -> do- putErrorLn $ str <> " at " <> showSDocUnsafe (ppr loc)- when- ( config- & _conf_debug- & _dconf_dump_ast_unknown- & confUnpack- )- $ do- putErrorLn $ " " ++ show (astToDoc ast)- _ -> error "cannot happen (TM)"- warns@(LayoutWarning{} : _) -> do- putErrorLn $ "WARNINGS:"- warns `forM_` \case- LayoutWarning str -> putErrorLn str- _ -> error "cannot happen (TM)"- unused@(ErrorUnusedComment{} : _) -> do- putErrorLn- $ "Error: detected unprocessed comments."- ++ " The transformation output will most likely"- ++ " not contain some of the comments"- ++ " present in the input haskell source file."- putErrorLn $ "Affected are the following comments:"- unused `forM_` \case- ErrorUnusedComment str -> putErrorLn str- _ -> error "cannot happen (TM)"- (ErrorMacroConfig err input : _) -> do- putErrorLn $ "Error: parse error in inline configuration:"- putErrorLn err- putErrorLn $ " in the string \"" ++ input ++ "\"."- [] -> error "cannot happen"- -- TODO: don't output anything when there are errors unless user- -- adds some override?- let- hasErrors =- case config & _conf_errorHandling & _econf_Werror & confUnpack of- False -> 0 < maximum (-1 : fmap customErrOrder errsWarns)- True -> not $ null errsWarns- outputOnErrs =- config- & _conf_errorHandling- & _econf_produceOutputOnErrors- & confUnpack- shouldOutput = not suppressOutput && (not hasErrors || outputOnErrs)-- let noChanges = outSText == originalContents- when shouldOutput- $ addTraceSep (_conf_debug config)- $ case outputPathM of- Nothing -> liftIO $ Text.IO.putStr $ outSText- Just p -> liftIO $ do- let isIdentical = case inputPathM of- Nothing -> False- Just _ -> noChanges- unless isIdentical $ Text.IO.writeFile p $ outSText-- when hasErrors $ ExceptT.throwE 70- return (if noChanges then NoChanges else Changes)- where- addTraceSep conf =- if or- [ confUnpack $ _dconf_dump_annotations conf- , confUnpack $ _dconf_dump_ast_unknown conf- , confUnpack $ _dconf_dump_ast_full conf- , confUnpack $ _dconf_dump_bridoc_raw conf- , confUnpack $ _dconf_dump_bridoc_simpl_alt conf- , confUnpack $ _dconf_dump_bridoc_simpl_floating conf- , confUnpack $ _dconf_dump_bridoc_simpl_columns conf- , confUnpack $ _dconf_dump_bridoc_simpl_indent conf- , confUnpack $ _dconf_dump_bridoc_final conf- ]- then trace "----"- else id+main = BrittanyMain.main
src-literatetests/10-tests.blt view
@@ -313,6 +313,303 @@ ############################################################################### ############################################################################### ###############################################################################+#group data type declarations+###############################################################################+###############################################################################+###############################################################################++#test nullary data type+data Foo = Bar {}++data Biz = Baz++#test single record+data Foo = Bar+ { foo :: Baz+ }++#test record multiple names+data Foo = Bar+ { foo, bar :: Baz+ }++#test record multiple types+data Foo = Bar+ { foo :: Baz+ , bars :: Bizzz+ }++#test record multiple types and names+data Foo = Bar+ { foo, biz :: Baz+ , bar :: Bizzz+ }++#test record multiple types deriving+data Foo = Bar+ { fooz :: Baz+ , bar :: Bizzz+ }+ deriving Show++#test record long field names+data MyRecord = MyConstructor+ { bar1, bar2+ :: Loooooooooooooooooooooooooooooooong+ -> Loooooooooooooooooooooooooooooooong+ , foo1, foo2+ :: Loooooooooooooooooooooooooooooooonger+ -> Loooooooooooooooooooooooooooooooonger+ }++#test record with DataTypeContexts+{-# LANGUAGE DatatypeContexts #-}+data+ ( LooooooooooooooooooooongConstraint a+ , LooooooooooooooooooooongConstraint b+ ) =>+ MyRecord a b+ = MyConstructor+ { foo1, foo2+ :: loooooooooooooooooooooooooooooooong+ -> loooooooooooooooooooooooooooooooong+ , bar :: a+ , bazz :: b+ }++#test record single line layout+#pending config flag is disabled for now+{-# LANGUAGE ScopedTypeVariables #-}+-- brittany { lconfig_allowSinglelineRecord: true }+data MyRecord = forall a . Show a => MyCons { foo :: a -> a, i :: Int }++#test record no matching single line layout+{-# LANGUAGE ScopedTypeVariables #-}+-- brittany { lconfig_allowSinglelineRecord: true }+data MyRecord = forall a . Show a => Bar+ { foo :: abittoolongbutnotvery -> abittoolongbutnotvery+ }++#test record forall constraint multiline+{-# LANGUAGE ScopedTypeVariables #-}+data MyRecord+ = forall a+ . LooooooooooooooooooooongConstraint a =>+ LoooooooooooongConstructor+ { foo :: abittoolongbutnotvery -> abittoolongbutnotvery+ }++#test record forall constraint multiline more+{-# LANGUAGE ScopedTypeVariables #-}+data MyRecord+ = forall a b+ . ( Loooooooooooooooooooooooooooooooong a+ , Loooooooooooooooooooooooooooooooong b+ ) =>+ MyConstructor+ { a :: a+ , b :: b+ }++#test plain with forall and constraint+{-# LANGUAGE ScopedTypeVariables #-}+data MyStruct+ = forall a b+ . ( Loooooooooooooooooooooooooooooooong a+ , Loooooooooooooooooooooooooooooooong b+ ) =>+ MyConstructor (ToBriDocM BriDocNumbered)+ (ToBriDocM BriDocNumbered)+ (ToBriDocM BriDocNumbered)++#test record with many features+{-# LANGUAGE ScopedTypeVariables #-}+data MyRecord+ = forall a b+ . ( Loooooooooooooooooooooooooooooooong a+ , Loooooooooooooooooooooooooooooooong b+ ) =>+ MyConstructor+ { foo, foo2+ :: loooooooooooooooooooooooooooooooong+ -> loooooooooooooooooooooooooooooooong+ , bar :: a+ , bazz :: b+ }+ deriving Show++#test record multiple types deriving+data Foo = Bar+ { foo :: Baz+ , bars :: Bizzz+ }+ deriving (Show, Eq, Monad, Functor, Traversable, Foldable)++#test record multiple deriving strategies+#min-ghc 8.2+data Foo = Bar+ { foo :: Baz+ , bars :: Bizzz+ }+ deriving Show+ deriving (Eq, Ord)+ deriving stock Show+ deriving stock (Eq, Ord)+ deriving anyclass Show+ deriving anyclass (Show, Eq, Monad, Functor)+ deriving newtype Show+ deriving newtype (Traversable, Foldable)++#test record deriving via+#min-ghc 8.6+data Foo = Bar+ { foo :: Baz+ , bars :: Bizzz+ }+ deriving ToJSON via (SomeType)+ deriving (ToJSON, FromJSON) via (SomeType)++#test single record existential+{-# LANGUAGE ExistentialQuantification #-}++data Foo = forall a . Show a => Bar+ { foo :: a+ }++#test record multiple types existential+{-# LANGUAGE ExistentialQuantification #-}++data Foo = forall a b . (Show a, Eq b) => Bar+ { foo :: a+ , bars :: b+ }++#test plain comment simple+-- before+data MyData = MyData Int+-- after++#test record newline comment+data MyRecord = MyRecord+ { a :: Int+ -- comment+ , b :: Int+ }++#test record comments simple+data Foo = Bar -- a+ { foo :: Baz -- b+ , bars :: Bizzz -- c+ } -- d+ deriving (Show, Eq, Monad, Functor, Traversable, Foldable) -- e++#test record comments strange inline+data Foo = Bar+ { -- a+ foo -- b+ :: -- c+ Baz -- d+ , -- e+ bars :: Bizzz+ }+ deriving (Show, Eq, Monad, Functor, Traversable, Foldable)++#test record comments in deriving+## maybe we want to switch to a differnt layout when there are such comments.+## Don't hesitate to modify this testcase, it clearly is not the ideal layout+## for this.++data Foo = Bar+ { foo :: Baz+ , bars :: Bizzz+ }+ -- a+ deriving --b+ ( -- c+ ToJSON -- d+ , -- e+ FromJSON --f+ ) -- g++#test record comments in deriving via+## maybe we want to switch to a differnt layout when there are such comments.+## Don't hesitate to modify this testcase, it clearly is not the ideal layout+## for this.+#min-ghc 8.6++data Foo = Bar+ { foo :: Baz+ , bars :: Bizzz+ }+ -- a+ deriving --a+ ToJSON --b+ via -- c+ ( -- d+ SomeType --e+ , -- f+ ABC --g+ )++#test comment before equal sign+{-# LANGUAGE ExistentialQuantification #-}+data MyRecord+ -- test comment+ = forall a b+ . ( Loooooooooooooooooooooooooooooooong a+ , Loooooooooooooooooooooooooooooooong b+ ) =>+ MyConstructor a b++#test normal records on multi line indent policy left+-- brittany {lconfig_indentPolicy: IndentPolicyLeft }+data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse+ Types.Company+ [EnterpriseGrantResponse]++#test normal records on multi line indent policy free+-- brittany {lconfig_indentPolicy: IndentPolicyFree }+data GrantsForCompanyResp = GrantsForCompanyResp Types.Company+ [EnterpriseGrantResponse]++#test normal records on multi line indent policy free 2+-- brittany {lconfig_indentPolicy: IndentPolicyFree }+data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse+ Types.Company+ [EnterpriseGrantResponse]++#test normal records on multi line indent policy multiple+-- brittany {lconfig_indentPolicy: IndentPolicyMultiple }+data GrantsForCompanyResp = GrantsForCompanyResp Types.Company+ [EnterpriseGrantResponse]++#test large record with a comment+data XIILqcacwiuNiu = XIILqcacwiuNiu+ { oyyFtvbepgbOge_pebzVmuftEijwuj :: Jgtoyuh HessJvNlo+ , wloQsiskdoxJop_xatiKrwedOxtu :: Jgtoyuh [Inotg]+ , mmmJjcqtemyIyo_ovosDoreKeeoyamvove :: Jgtoyuh Eujo+ , mbiIatelofxOzr_uluxNngiiMjah :: Jgtoyuh HessJvNlo+ , obxIskfcxpkIkb_uuviTuevcSkrgo :: Jgtoyuh Int+ , wqrAtuvuecoHwr_ilotNxbuPleo :: Jgtoyuh Ufaxdeq+ , lofAfuebdhpLuv_cnekPoyFxmg :: Jgtoyuh Ufaxdeq+ , ouoFugtawzvUpk_oupiLzptugy :: Jgtoyuh Eujo+ , iqiXjtziwogNsa_uiyvSunaTtgUsf3 :: Jgtoyuh Oaivn+ , odbIriaqnojUlz_onotoWuunehIpuy :: Jgtoyuh Eujo+ , opjUxtkxzkiKse_luqjuZazt+ :: Jgtoyuh [(Eujo, Int, Int, Int, Int, Int, NELUxro)]+ -- , jcqRaqznxfhIpa_ywevMezmoYkutuwa :: Jgtoyuh ()+ , vayOmuasyphOfd_bcsVljmvt :: Jgtoyuh Eujo+ , rifArahilooRax_ufikecqdImsv :: Jgtoyuh Oaivn+ , raqKtopcpszDwb_oqocubasZuqjcryoDojGkw :: Jgtoyuh Oaivn+ , mluJiilpcijUtt_gaisklifVekfeyagRmfbyzz :: Jgtoyuh Oaivn+ , oqhPaahjupaSmi_gamwwoovKyxznecvEayluc :: Jgtoyuh Oaivn+ , mazFubimwebZpa_itidehDodiDlboz :: Jgtoyuh Vrep+ , jeyOcuesexaYoy_vpqn :: Jgtoyuh ()+ }++###############################################################################+###############################################################################+############################################################################### #group equation.basic ############################################################################### ###############################################################################@@ -704,8 +1001,7 @@ , test7 , test8 , test9- )-where+ ) where #test exports-with-comments module Main@@ -719,8 +1015,7 @@ -- Test 5 , test5 -- Test 6- )-where+ ) where #test simple-export-with-things module Main (Test(..)) where@@ -738,7 +1033,7 @@ ( Test(Test, a, b) , foo -- comment2 ) -- comment3-where+ where #test export-with-empty-thing module Main (Test()) where@@ -989,8 +1284,7 @@ , test9 , test10 -- Test 10- )-where+ ) where -- Test import Data.List ( nub ) -- Test@@ -1093,7 +1387,15 @@ type ((a :+: b) c) = (a, c) +#test synonym-tuple-type-many-comments +type Foo+ = ( -- t1+ A -- t2+ , -- t3+ B -- t4+ ) -- t5+ ############################################################################### ############################################################################### ###############################################################################@@ -1207,6 +1509,24 @@ { intData :: String -- ^ Interesting field , intData2 :: Int+ }++#test instance-with-newtype-family-and-deriving++{-# LANGUAGE TypeFamilies #-}++module Lib where++instance Foo () where+ newtype Bar () = Baz ()+ deriving (Eq, Ord, Show)+ bar = Baz++#test instance-with-newtype-family-and-record++instance Foo Int where+ newtype Bar Int = BarInt+ { unBarInt :: Int }
src-literatetests/14-extensions.blt view
@@ -83,6 +83,90 @@ ) ###############################################################################+## PatternSynonyms+#test bidirectional pattern+{-# LANGUAGE PatternSynonyms #-}+pattern J x = Just x++#test unidirection pattern+{-# LANGUAGE PatternSynonyms #-}+pattern F x <- (x, _)++#test explicitly bidirectional pattern+{-# LANGUAGE PatternSynonyms #-}+pattern HeadC x <- x : xs where+ HeadC x = [x]++#test Multiple arguments+{-# LANGUAGE PatternSynonyms #-}+pattern Head2 x y <- x : y : xs where+ Head2 x y = [x, y]++#test Infix argument+{-# LANGUAGE PatternSynonyms #-}+pattern x :> y = [x, y]++#test Record argument+{-# LANGUAGE PatternSynonyms #-}+pattern MyData { a, b, c } = [a, b, c]++#test long pattern match+{-# LANGUAGE PatternSynonyms #-}+pattern myLongLeftVariableName `MyLongInfixPatternMatcher` myLongRightVariableName =+ [myLongLeftVariableName, myLongRightVariableName]++#test long explicitly bidirectional match+{-# LANGUAGE PatternSynonyms #-}+pattern myLeftVariableName `MyInfixPatternMatcher` myRightVariableName <-+ [myLongLeftVariableName, myLongRightVariableName] where+ MyInfixPatternMatcher x y = [x, x, y]++#test Pattern synonym types +{-# LANGUAGE PatternSynonyms #-}+pattern J :: a -> Maybe a+pattern J x = Just x++#test pattern synonym bidirectional multiple cases+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+pattern Signed x <- (asSigned -> x) where+ Signed (Neg x) = -x+ Signed Zero = 0+ Signed (Pos x) = x++#test pattern synonym bidirectional multiple cases long+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+pattern Signed xxxxxxxxxxxxxxxxxxxxxxxx <-+ (asSigned -> xxxxxxxxxxxxxxxxxxxxxxxx) where+ Signed (Neg x) = -x+ Signed Zero = 0+ Signed (Pos x) = x++#test pattern synonym bidirectional multiple cases with comments+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+pattern Signed x <- (asSigned -> x) where+ Signed (Neg x) = -x -- negative comment+ Signed Zero = 0 -- zero comment+ Signed (Pos x) = x -- positive comment++#test Pattern synonym types multiple names+#min-ghc 8.2+{-# LANGUAGE PatternSynonyms #-}+pattern J, K :: a -> Maybe a++#test Pattern synonym type sig wrapped+{-# LANGUAGE PatternSynonyms #-}+pattern LongMatcher+ :: longlongtypevar+ -> longlongtypevar+ -> longlongtypevar+ -> Maybe [longlongtypevar]+pattern LongMatcher x y z = Just [x, y, z]+++############################################################################### ## UnboxedTuples + MagicHash #test unboxed-tuple and vanilla names {-# LANGUAGE UnboxedTuples #-}
src-literatetests/15-regressions.blt view
@@ -363,14 +363,13 @@ #test recordupd-singleline-bug runBrittany tabSize text = do- let- config' = staticDefaultConfig- config = config'- { _conf_layout = (_conf_layout config') { _lconfig_indentAmount = coerce- tabSize- }- , _conf_forward = forwardOptionsSyntaxExtsEnabled- }+ let config' = staticDefaultConfig+ config = config'+ { _conf_layout = (_conf_layout config')+ { _lconfig_indentAmount = coerce tabSize+ }+ , _conf_forward = forwardOptionsSyntaxExtsEnabled+ } parsePrintModule config text #test recordupd-singleline-bug-left@@ -770,3 +769,117 @@ , -- N.B. .. -- x }++#test issue 263++func = abc + def+ -- a+ -- b++ -- comment++ where+ abc = 13+ def = 1++#test AddBaseY/EnsureIndent float in effect++zItazySunefp twgq nlyo lwojjoBiecao =+ let mhIarjyai =+ ukwAausnfcn+ $ XojlsTOSR.vuwOvuvdAZUOJaa+ $ XojlsTOSR.vkesForanLiufjeDI+ $ XojlsTOSR.vkesForanLiufjeDI+ $ XojlsTOSR.popjAyijoWarueeP+ $ XojlsTOSR.jpwuPmafuDqlbkt nlyo+ $ XojlsTOSR.jpwuPmafuDqlbkt xxneswWhxwng+ $ XojlsTOSR.jpwuPmafuDqlbkt oloCuxeDdow+ $ XojlsTOSR.jpwuPmafuDqlbkt (uwurrvoNnukzefuDjeh lwojjoBiecao nlyo)+ $ etOslnoz lwojjoBiecao+ in kucotg $ (bbbr, Yoxe.Dwzbuzi.zrLokoTnuy piv)++#test module initial comment+-- test+module MyModule where++#test issue 231++foo =+ [ ("xxx", "xx")+ , --+ ("xx" , "xx")+ --+ , ("xx" , "xxxxx")+ , ("xx" , "xx")+ ]++#test issue 231 not++foo =+ [ ("xx", "xx")+ , ( "xx" --+ , "xx"+ )+ , ("xx", "xxxxx")+ , ("xx", "xx")+ ]++#test issue 281++module Main+ ( DataTypeI+ , DataTypeII(DataConstructor)+ -- * Haddock heading+ , name+ ) where++#test type level list++xeoeqibIaib+ :: ( KqujhIsaus m+ , XivuvIpoboi Droqifim m+ , IgorvOtowtf m+ , RyagaYaqac m+ , QouruDU m+ )+ => MaptAdfuxgu+ -> Zcnxg NsxayqmvIjsezea -- ^ if Lvqucoo, opsip jl reyoyhk lfil qaculxgd+ -> QNOZqwuzg+ -> Eoattuq+ '[ XkatytdWdquraosu -- test comment+ , KyezKijim -- another test comment+ , DjmioeePuoeg+ , NinrxoiOwezc+ , QATAlrijacpk+ , TrutvotwIwifiqOjdtu+ , CoMmuatjwr+ , BoZckzqyodseZole+ , VagfwoXaeChfqe+ ]+ m+ ()++#test recordupd-overflow-bad-multiline-spacing++createRedirectedProcess processConfig = do+ let redirectedProc = (_processConfig_inner processConfig)+ { std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ }+ foo++#test issue 282++instance HasDependencies SomeDataModel where+ -- N.B. Here is a bunch of explanatory context about the relationship+ -- between these data models or whatever.+ type Dependencies SomeDataModel+ = (SomeOtherDataModelId, SomeOtherOtherDataModelId)++#test stupid-do-operator-combination++func =+ do+ y+ >>= x
src-literatetests/30-tests-context-free.blt view
@@ -315,6 +315,51 @@ ############################################################################### ############################################################################### ###############################################################################+#group data type declarations+###############################################################################+###############################################################################+###############################################################################++#test single record+data Foo = Bar+ { foo :: Baz+ }++#test record multiple names+data Foo = Bar+ { foo, bar :: Baz+ }++#test record multiple types+data Foo = Bar+ { foo :: Baz+ , bar :: Bizzz+ }++#test record multiple types and names+data Foo = Bar+ { foo, biz :: Baz+ , bar :: Bizzz+ }++#test record multiple types deriving+data Foo = Bar+ { foo :: Baz+ , bar :: Bizzz+ }+ deriving Show++#test record multiple types deriving+data Foo = Bar+ { foo :: Baz+ , bar :: Bizzz+ }+ deriving (Show, Eq, Monad, Functor, Traversable, Foldable)+++###############################################################################+###############################################################################+############################################################################### #group equation.basic ############################################################################### ###############################################################################@@ -630,8 +675,7 @@ , test7 , test8 , test9- )-where+ ) where #test exports-with-comments module Main@@ -645,8 +689,7 @@ -- Test 5 , test5 -- Test 6- )-where+ ) where #test simple-export-with-things module Main (Test(..)) where@@ -868,8 +911,7 @@ , test8 , test9 , test10- )-where+ ) where -- Test import Data.List (nub) -- Test@@ -1162,6 +1204,12 @@ ReflexHost.newExternalEvent liftIO . forkIO . forever $ getLine >>= inputFire ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent++#test issue 15+-- Test.hs+module Test where++data X = X #test issue 16 foldrDesc f z = unSwitchQueue $ \q ->
src-literatetests/Main.hs view
@@ -1,42 +1,54 @@ {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE CPP #-} -module Main (main) where+module Main+ ( main+ )+where #include "prelude.inc" -import Test.Hspec-import Test.Hspec.Runner ( hspecWith, defaultConfig, configConcurrentJobs )--import NeatInterpolation+import Test.Hspec+import Test.Hspec.Runner ( hspecWith+ , defaultConfig+ , configConcurrentJobs+ ) -import qualified Text.Parsec as Parsec-import Text.Parsec.Text ( Parser )+import qualified Text.Parsec as Parsec+import Text.Parsec.Text ( Parser ) -import Data.Char ( isSpace )-import Data.List ( groupBy )+import Data.Char ( isSpace )+import Data.List ( groupBy ) -import Language.Haskell.Brittany.Internal+import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config.Types-import Language.Haskell.Brittany.Internal.Config+import Language.Haskell.Brittany.Internal.Config.Types+import Language.Haskell.Brittany.Internal.Config -import Data.Coerce ( coerce )+import Data.Coerce ( coerce ) -import qualified Data.Text.IO as Text.IO-import System.FilePath ( (</>) )+import qualified Data.Text.IO as Text.IO+import System.FilePath ( (</>) ) data InputLine = GroupLine Text | HeaderLine Text+ | GhcVersionGuardLine Text | PendingLine | NormalLine Text | CommentLine deriving Show +data TestCase = TestCase+ { testName :: Text+ , isPending :: Bool+ , minGHCVersion :: Maybe Text+ , content :: Text+ } main :: IO () main = do@@ -44,28 +56,39 @@ let blts = List.sort $ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x))- $ filter (".blt"`isSuffixOf`) files+ $ filter (".blt" `isSuffixOf`) files inputs <- blts `forM` \blt -> Text.IO.readFile ("src-literatetests" </> blt) let groups = createChunks =<< inputs inputCtxFree <- Text.IO.readFile "src-literatetests/30-tests-context-free.blt" let groupsCtxFree = createChunks inputCtxFree+ let parseVersion :: Text -> Maybe [Int]+ parseVersion =+ mapM (readMaybe . Text.unpack) . Text.splitOn (Text.pack ".")+ let ghcVersion = Data.Maybe.fromJust $ parseVersion $ Text.pack VERSION_ghc+ let checkVersion = \case+ Nothing -> True -- no version constraint+ Just s -> case parseVersion s of+ Nothing -> error $ "could not parse version " ++ Text.unpack s+ Just v -> v <= ghcVersion hspec $ do groups `forM_` \(groupname, tests) -> do- describe (Text.unpack groupname) $ tests `forM_` \(name, pend, inp) -> do- (if pend then before_ pending else id)- $ it (Text.unpack name)- $ roundTripEqual defaultTestConfig inp+ describe (Text.unpack groupname) $ do+ tests `forM_` \test -> when (checkVersion $ minGHCVersion test) $ do+ (if isPending test then before_ pending else id)+ $ it (Text.unpack $ testName test)+ $ roundTripEqual defaultTestConfig+ $ content test groupsCtxFree `forM_` \(groupname, tests) -> do- describe ("context free: " ++ Text.unpack groupname)- $ tests- `forM_` \(name, pend, inp) -> do- (if pend then before_ pending else id)- $ it (Text.unpack name)- $ roundTripEqual contextFreeTestConfig inp+ describe ("context free: " ++ Text.unpack groupname) $ do+ tests `forM_` \test -> when (checkVersion $ minGHCVersion test) $ do+ (if isPending test then before_ pending else id)+ $ it (Text.unpack $ testName test)+ $ roundTripEqual contextFreeTestConfig+ $ content test where -- this function might be implemented in a weirdly complex fashion; the -- reason being that it was copied from a somewhat more complex variant.- createChunks :: Text -> [(Text, [(Text, Bool, Text)])]+ createChunks :: Text -> [(Text, [TestCase])] createChunks input = -- fmap (\case -- HeaderLine n:PendingLine:rest | Just rlines <- mapM extractNormal rest -> (n, True, Text.unlines rlines)@@ -73,35 +96,39 @@ -- l -> error $ "first non-empty line must start with #test footest\n" ++ show l -- ) -- $ fmap (groupBy grouperT)- fmap- ( \case- GroupLine g:grouprest ->- (,) g- $ fmap- ( \case- HeaderLine n:PendingLine:rest | Just rlines <- mapM- extractNormal- rest ->- (n, True, Text.unlines rlines)- HeaderLine n:rest | Just rlines <- mapM extractNormal rest ->- (n, False, Text.unlines rlines)- l ->- error- $ "first non-empty line must start with #test footest\n"- ++ show l- )- $ groupBy grouperT- $ filter (not . lineIsSpace)- $ grouprest- l -> error $ "first non-empty line must be a #group\n" ++ show l- )- $ groupBy grouperG- $ filter (not . lineIsSpace)- $ lineMapper- <$> Text.lines input+ fmap groupProcessor+ $ groupBy grouperG+ $ filter (not . lineIsSpace)+ $ fmap lineMapper+ $ Text.lines input where+ groupProcessor :: [InputLine] -> (Text, [TestCase])+ groupProcessor = \case+ GroupLine g : grouprest ->+ (,) g+ $ fmap testProcessor+ $ groupBy grouperT+ $ filter (not . lineIsSpace)+ $ grouprest+ l -> error $ "first non-empty line must be a #group\n" ++ show l+ testProcessor :: [InputLine] -> TestCase+ testProcessor = \case+ HeaderLine n : rest ->+ let normalLines = Data.Maybe.mapMaybe extractNormal rest+ in TestCase+ { testName = n+ , isPending = any isPendingLine rest+ , minGHCVersion = Data.List.Extra.firstJust extractMinGhc rest+ , content = Text.unlines normalLines+ }+ l ->+ error $ "first non-empty line must start with #test footest\n" ++ show l extractNormal (NormalLine l) = Just l extractNormal _ = Nothing+ extractMinGhc (GhcVersionGuardLine v) = Just v+ extractMinGhc _ = Nothing+ isPendingLine PendingLine{} = True+ isPendingLine _ = False specialLineParser :: Parser InputLine specialLineParser = Parsec.choice [ [ GroupLine $ Text.pack name@@ -116,6 +143,11 @@ , name <- Parsec.many1 $ Parsec.noneOf "\r\n:" , _ <- Parsec.eof ]+ , [ GhcVersionGuardLine $ Text.pack version+ | _ <- Parsec.try $ Parsec.string "#min-ghc"+ , _ <- Parsec.many1 $ Parsec.oneOf " \t"+ , version <- Parsec.many1 $ Parsec.noneOf "\r\n:"+ ] , [ PendingLine | _ <- Parsec.try $ Parsec.string "#pending" , _ <- Parsec.optional $ many (Parsec.noneOf "\r\n")@@ -123,8 +155,8 @@ ] , [ CommentLine | _ <- Parsec.many $ Parsec.oneOf " \t"- , _ <-- Parsec.optional $ Parsec.string "##" <* many (Parsec.noneOf "\r\n")+ , _ <- Parsec.optional $ Parsec.string "##" <* many+ (Parsec.noneOf "\r\n") , _ <- Parsec.eof ] ]@@ -148,8 +180,7 @@ -------------------- roundTripEqual :: Config -> Text -> Expectation roundTripEqual c t =- fmap (fmap PPTextWrapper)- (parsePrintModuleTests c "TestFakeFileName.hs" t)+ fmap (fmap PPTextWrapper) (parsePrintModuleTests c "TestFakeFileName.hs" t) `shouldReturn` Right (PPTextWrapper t) newtype PPTextWrapper = PPTextWrapper Text@@ -158,7 +189,8 @@ instance Show PPTextWrapper where show (PPTextWrapper t) = "\n" ++ Text.unpack t -+-- brittany-next-binding --columns 160+-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } defaultTestConfig :: Config defaultTestConfig = Config { _conf_version = _conf_version staticDefaultConfig@@ -180,22 +212,21 @@ , _lconfig_allowSingleLineExportList = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False- }- , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig)- { _econf_omit_output_valid_check = coerce True+ -- , _lconfig_allowSinglelineRecord = coerce False }+ , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } , _conf_preprocessor = _conf_preprocessor staticDefaultConfig- , _conf_forward = ForwardOptions {_options_ghc = Identity []}+ , _conf_forward = ForwardOptions { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False- , _conf_obfuscate = coerce False+ , _conf_disable_formatting = coerce False+ , _conf_obfuscate = coerce False } contextFreeTestConfig :: Config-contextFreeTestConfig =- defaultTestConfig+contextFreeTestConfig = defaultTestConfig { _conf_layout = (_conf_layout defaultTestConfig)- {_lconfig_indentPolicy = coerce IndentPolicyLeft- ,_lconfig_alignmentLimit = coerce (1 :: Int)- ,_lconfig_columnAlignMode = coerce ColumnAlignModeDisabled- }+ { _lconfig_indentPolicy = coerce IndentPolicyLeft+ , _lconfig_alignmentLimit = coerce (1 :: Int)+ , _lconfig_columnAlignMode = coerce ColumnAlignModeDisabled+ } }
src-unittests/AsymptoticPerfTests.hs view
@@ -11,8 +11,6 @@ import Test.Hspec -import NeatInterpolation- import Language.Haskell.Brittany.Internal import TestUtils
src-unittests/TestMain.hs view
@@ -8,8 +8,6 @@ import Test.Hspec -import NeatInterpolation- import Language.Haskell.Brittany.Internal import AsymptoticPerfTests
src-unittests/TestUtils.hs view
@@ -8,7 +8,7 @@ import Test.Hspec -import NeatInterpolation+-- import NeatInterpolation import Language.Haskell.Brittany.Internal @@ -61,6 +61,7 @@ , _lconfig_allowSingleLineExportList = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False+ -- , _lconfig_allowSinglelineRecord = coerce False } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever@@ -68,5 +69,6 @@ , _conf_preprocessor = (_conf_preprocessor staticDefaultConfig) , _conf_forward = ForwardOptions {_options_ghc = Identity []} , _conf_roundtrip_exactprint_only = coerce False+ , _conf_disable_formatting = coerce False , _conf_obfuscate = coerce False }
src/Language/Haskell/Brittany/Internal.hs view
@@ -51,13 +51,15 @@ import Language.Haskell.Brittany.Internal.Transformations.Columns import Language.Haskell.Brittany.Internal.Transformations.Indent -import qualified GHC as GHC+import qualified GHC as GHC hiding ( parseModule ) import ApiAnnotation ( AnnKeywordId(..) )-import GHC ( runGhc+import GHC ( Located+ , runGhc , GenLocated(L) , moduleNameString )+import RdrName ( RdrName(..) ) import SrcLoc ( SrcSpan ) import HsSyn import qualified DynFlags as GHC@@ -158,6 +160,12 @@ Butcher.addCmd "-disable-next-declaration" disableNextDecl Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl+ let disableFormatting = do+ Butcher.addCmdImpl+ ( InlineConfigTargetModule+ , mempty { _conf_disable_formatting = pure $ pure True }+ )+ Butcher.addCmd "-disable" disableFormatting Butcher.addCmd "@" $ do -- Butcher.addCmd "module" $ do -- conf <- configParser@@ -264,38 +272,47 @@ (inlineConf, perItemConf) <- either (throwE . (: []) . uncurry ErrorMacroConfig) pure $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)- let moduleConfig = cZipWith fromOptionIdentity config inlineConf- (errsWarns, outputTextL) <- do- let omitCheck =- moduleConfig- & _conf_errorHandling- & _econf_omit_output_valid_check- & confUnpack- (ews, outRaw) <- if hasCPP || omitCheck- then return $ pPrintModule moduleConfig perItemConf anns parsedSource- else lift- $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource- let hackF s = fromMaybe s- $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s- pure $ if hackAroundIncludes- then- ( ews- , TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn- (TextL.pack "\n")- outRaw- )- else (ews, outRaw)- let customErrOrder ErrorInput{} = 4- customErrOrder LayoutWarning{} = 0 :: Int- customErrOrder ErrorOutputCheck{} = 1- customErrOrder ErrorUnusedComment{} = 2- customErrOrder ErrorUnknownNode{} = 3- customErrOrder ErrorMacroConfig{} = 5- let hasErrors =- case moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack of- False -> 0 < maximum (-1 : fmap customErrOrder errsWarns)- True -> not $ null errsWarns- if hasErrors then throwE $ errsWarns else pure $ TextL.toStrict outputTextL+ let moduleConfig = cZipWith fromOptionIdentity config inlineConf+ let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack+ if disableFormatting+ then do+ return inputText+ else do+ (errsWarns, outputTextL) <- do+ let omitCheck =+ moduleConfig+ & _conf_errorHandling+ & _econf_omit_output_valid_check+ & confUnpack+ (ews, outRaw) <- if hasCPP || omitCheck+ then return $ pPrintModule moduleConfig perItemConf anns parsedSource+ else lift+ $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource+ let hackF s = fromMaybe s+ $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s+ pure $ if hackAroundIncludes+ then+ ( ews+ , TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn+ (TextL.pack "\n")+ outRaw+ )+ else (ews, outRaw)+ let customErrOrder ErrorInput{} = 4+ customErrOrder LayoutWarning{} = 0 :: Int+ customErrOrder ErrorOutputCheck{} = 1+ customErrOrder ErrorUnusedComment{} = 2+ customErrOrder ErrorUnknownNode{} = 3+ customErrOrder ErrorMacroConfig{} = 5+ let hasErrors =+ case+ moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack+ of+ False -> 0 < maximum (-1 : fmap customErrOrder errsWarns)+ True -> not $ null errsWarns+ if hasErrors+ then throwE $ errsWarns+ else pure $ TextL.toStrict outputTextL @@ -458,9 +475,15 @@ let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack toLocal config' filteredAnns $ do- bd <- briDocMToPPM $ if exactprintOnly- then briDocByExactNoComment decl- else layoutDecl decl+ bd <- if exactprintOnly+ then briDocMToPPM $ briDocByExactNoComment decl+ else do+ (r, errs, debugs) <- briDocMToPPMInner $ layoutDecl decl+ mTell debugs+ mTell errs+ if null errs+ then pure r+ else briDocMToPPM $ briDocByExactNoComment decl layoutBriDoc bd let finalComments = filter@@ -485,7 +508,6 @@ in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) _ -> return () - getDeclBindingNames :: LHsDecl GhcPs -> [String] #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ getDeclBindingNames (L _ decl) = case decl of@@ -519,7 +541,7 @@ let (filteredAnns', post) =- case (ExactPrint.mkAnnKey lmod) `Map.lookup` filteredAnns of+ case Map.lookup (ExactPrint.mkAnnKey lmod) filteredAnns of Nothing -> (filteredAnns, []) Just mAnn -> let@@ -535,23 +557,7 @@ (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp (Nothing, Just _i) -> ([], modAnnsDp) (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp- findInitialCommentSize = \case- ((ExactPrint.AnnComment cm, ExactPrint.DP (y, _)) : rest) ->- let GHC.RealSrcSpan span = ExactPrint.commentIdentifier cm- in y- + GHC.srcSpanEndLine span- - GHC.srcSpanStartLine span- + findInitialCommentSize rest- _ -> 0- initialCommentSize = findInitialCommentSize pre- fixAbsoluteModuleDP = \case- (g@(ExactPrint.G AnnModule), ExactPrint.DP (y, x)) ->- (g, ExactPrint.DP (y - initialCommentSize, x))- x -> x- pre' = if shouldReformatPreamble- then map fixAbsoluteModuleDP pre- else pre- mAnn' = mAnn { ExactPrint.annsDP = pre' }+ mAnn' = mAnn { ExactPrint.annsDP = pre } filteredAnns'' = Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns in@@ -650,6 +656,7 @@ , _lstate_comments = anns , _lstate_commentCol = Nothing , _lstate_addSepSpace = Nothing+ , _lstate_commentNewlines = 0 } state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
src/Language/Haskell/Brittany/Internal/Backend.hs view
@@ -174,14 +174,15 @@ priors `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> when (not $ comment == "(" || comment == ")") $ do+ let commentLines = Text.lines $ Text.pack $ comment case comment of- ('#':_) -> layoutMoveToCommentPos y (-999)+ ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) -- ^ evil hack for CPP- _ -> layoutMoveToCommentPos y x+ _ -> layoutMoveToCommentPos y x (length commentLines) -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline -- layoutMoveToIndentCol y- layoutWriteAppendMultiline $ Text.pack $ comment+ layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } when allowMTEL $ moveToExactAnn annKey layoutBriDocM bd@@ -214,14 +215,15 @@ Just comments -> do comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> when (not $ comment == "(" || comment == ")") $ do+ let commentLines = Text.lines $ Text.pack $ comment -- evil hack for CPP: case comment of- ('#':_) -> layoutMoveToCommentPos y (-999)- _ -> layoutMoveToCommentPos y x+ ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines)+ _ -> layoutMoveToCommentPos y x (length commentLines) -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline -- layoutMoveToIndentCol y- layoutWriteAppendMultiline $ Text.pack $ comment+ layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDAnnotationRest annKey bd -> do layoutBriDocM bd@@ -256,17 +258,18 @@ Just comments -> do comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> when (not $ comment == "(" || comment == ")") $ do+ let commentLines = Text.lines $ Text.pack comment case comment of- ('#':_) -> layoutMoveToCommentPos y (-999)+ ('#':_) -> layoutMoveToCommentPos y (-999) 1 -- ^ evil hack for CPP ")" -> pure () -- ^ fixes the formatting of parens -- on the lhs of type alias defs- _ -> layoutMoveToCommentPos y x+ _ -> layoutMoveToCommentPos y x (length commentLines) -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline -- layoutMoveToIndentCol y- layoutWriteAppendMultiline $ Text.pack $ comment+ layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do mDP <- do@@ -278,16 +281,20 @@ , (ExactPrint.Types.G kw1, dp) <- ann , keyword == kw1 ]- -- mTell $ Seq.fromList ["KWDP: " ++ show annKey ++ " " ++ show mAnn]- pure $ case relevant of- [] -> Nothing- (dp:_) -> Just dp+ -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant]+ case relevant of+ [] -> pure Nothing+ (ExactPrint.Types.DP (y, x):_) -> do+ mSet state { _lstate_commentNewlines = 0 }+ pure $ Just (y - _lstate_commentNewlines state, x) case mDP of Nothing -> pure ()- Just (ExactPrint.Types.DP (y, x)) ->- layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0)+ Just (y, x) ->+ -- we abuse this, as we probably will print the KW next, which is+ -- _not_ a comment..+ layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1 layoutBriDocM bd- BDNonBottomSpacing bd -> layoutBriDocM bd+ BDNonBottomSpacing _ bd -> layoutBriDocM bd BDSetParSpacing bd -> layoutBriDocM bd BDForceParSpacing bd -> layoutBriDocM bd BDDebug s bd -> do@@ -321,15 +328,15 @@ BDAnnotationKW _ _ bd -> rec bd BDAnnotationRest _ bd -> rec bd BDMoveToKWDP _ _ _ bd -> rec bd- BDLines ls@(_:_) -> do+ BDLines ls@(_ : _) -> do x <- StateS.get return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x- BDLines [] -> error "briDocLineLength BDLines []"- BDEnsureIndent _ bd -> rec bd- BDSetParSpacing bd -> rec bd- BDForceParSpacing bd -> rec bd- BDNonBottomSpacing bd -> rec bd- BDDebug _ bd -> rec bd+ BDLines [] -> error "briDocLineLength BDLines []"+ BDEnsureIndent _ bd -> rec bd+ BDSetParSpacing bd -> rec bd+ BDForceParSpacing bd -> rec bd+ BDNonBottomSpacing _ bd -> rec bd+ BDDebug _ bd -> rec bd briDocIsMultiLine :: BriDoc -> Bool briDocIsMultiLine briDoc = rec briDoc@@ -363,9 +370,9 @@ BDLines [_ ] -> False BDLines [] -> error "briDocIsMultiLine BDLines []" BDEnsureIndent _ bd -> rec bd- BDSetParSpacing bd -> rec bd- BDForceParSpacing bd -> rec bd- BDNonBottomSpacing bd -> rec bd+ BDSetParSpacing bd -> rec bd+ BDForceParSpacing bd -> rec bd+ BDNonBottomSpacing _ bd -> rec bd BDDebug _ bd -> rec bd -- In theory@@ -551,6 +558,8 @@ (BDCols ColBindStmt _) -> True (BDCols ColDoLet _) -> True (BDCols ColRec _) -> False+ (BDCols ColRecUpdate _) -> False+ (BDCols ColRecDecl _) -> False (BDCols ColListComp _) -> False (BDCols ColList _) -> False (BDCols ColApp{} _) -> True
src/Language/Haskell/Brittany/Internal/BackendUtils.hs view
@@ -122,12 +122,12 @@ , MonadMultiState LayoutState m , MonadMultiWriter (Seq String) m )- => Text+ => [Text] -> m ()-layoutWriteAppendMultiline t = do- traceLocal ("layoutWriteAppendMultiline", t)- case Text.lines t of- [] -> layoutWriteAppend t -- need to write empty, too.+layoutWriteAppendMultiline ts = do+ traceLocal ("layoutWriteAppendMultiline", ts)+ case ts of+ [] -> layoutWriteAppend (Text.pack "") -- need to write empty, too. (l:lr) -> do layoutWriteAppend l lr `forM_` \x -> do@@ -173,6 +173,8 @@ unless (Data.Maybe.isJust $ _lstate_commentCol state) $ mSet state { _lstate_commentCol = Just col } +-- This is also used to move to non-comments in a couple of places. Seems+-- to be harmless so far.. layoutMoveToCommentPos :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m@@ -180,9 +182,10 @@ ) => Int -> Int+ -> Int -> m ()-layoutMoveToCommentPos y x = do- traceLocal ("layoutMoveToCommentPos", y, x)+layoutMoveToCommentPos y x commentLines = do+ traceLocal ("layoutMoveToCommentPos", y, x, commentLines) state <- mGet mSet state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of@@ -200,6 +203,8 @@ Nothing -> case _lstate_curYOrAddNewline state of Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) Right{} -> lstate_baseY state+ , _lstate_commentNewlines =+ _lstate_commentNewlines state + y + commentLines - 1 } -- | does _not_ add spaces to again reach the current base column.@@ -219,6 +224,10 @@ , _lstate_addSepSpace = Nothing } +_layoutResetCommentNewlines :: MonadMultiState LayoutState m => m ()+_layoutResetCommentNewlines = do+ mModify $ \state -> state { _lstate_commentNewlines = 0 }+ layoutWriteEnsureNewlineBlock :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m@@ -245,9 +254,10 @@ -> m () layoutWriteEnsureAbsoluteN n = do state <- mGet- let diff = case _lstate_curYOrAddNewline state of- Left i -> n - i- Right{} -> n+ let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of+ (Just c , _ ) -> n - c+ (Nothing, Left i ) -> n - i+ (Nothing, Right{}) -> n traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) when (diff > 0) $ do mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to@@ -521,7 +531,7 @@ ) -> do replicateM_ x layoutWriteNewline layoutWriteAppendSpaces y- layoutWriteAppendMultiline $ Text.pack $ comment+ layoutWriteAppendMultiline $ Text.lines $ Text.pack comment -- TODO: update and use, or clean up. Currently dead code. -- this currently only extracs from the `annsDP` field of Annotations.@@ -557,7 +567,8 @@ ) -> do replicateM_ x layoutWriteNewline layoutWriteAppend $ Text.pack $ replicate y ' '- layoutWriteAppendMultiline $ Text.pack $ comment+ mModify $ \s -> s { _lstate_addSepSpace = Nothing }+ layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment layoutIndentRestorePostComment :: ( MonadMultiState LayoutState m@@ -572,7 +583,9 @@ #if INSERTTRACES tellDebugMessShow ("layoutIndentRestorePostComment", mCommentCol) #endif- mModify $ \s -> s { _lstate_commentCol = Nothing }+ mModify $ \s -> s { _lstate_commentCol = Nothing+ , _lstate_commentNewlines = 0+ } case (mCommentCol, eCurYAddNL) of (Just commentCol, Left{}) -> do layoutWriteEnsureNewlineBlock
src/Language/Haskell/Brittany/Internal/Config.hs view
@@ -29,24 +29,28 @@ import Data.CZipWith import UI.Butcher.Monadic-import Data.Monoid ((<>))+import Data.Monoid ( (<>) ) -import qualified System.Console.CmdArgs.Explicit as CmdArgs+import qualified System.Console.CmdArgs.Explicit+ as CmdArgs import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types.Instances import Language.Haskell.Brittany.Internal.Utils -import Data.Coerce ( Coercible, coerce )-import qualified Data.List.NonEmpty as NonEmpty+import Data.Coerce ( Coercible+ , coerce+ )+import qualified Data.List.NonEmpty as NonEmpty -import qualified System.Directory as Directory-import qualified System.FilePath.Posix as FilePath+import qualified System.Directory as Directory+import qualified System.FilePath.Posix as FilePath +-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } staticDefaultConfig :: Config staticDefaultConfig = Config- { _conf_version = coerce (1 :: Int)- , _conf_debug = DebugConfig+ { _conf_version = coerce (1 :: Int)+ , _conf_debug = DebugConfig { _dconf_dump_config = coerce False , _dconf_dump_annotations = coerce False , _dconf_dump_ast_unknown = coerce False@@ -60,60 +64,60 @@ , _dconf_dump_bridoc_final = coerce False , _dconf_roundtrip_exactprint_only = coerce False }- , _conf_layout = LayoutConfig- { _lconfig_cols = coerce (80 :: Int)- , _lconfig_indentPolicy = coerce IndentPolicyFree- , _lconfig_indentAmount = coerce (2 :: Int)- , _lconfig_indentWhereSpecial = coerce True- , _lconfig_indentListSpecial = coerce True- , _lconfig_importColumn = coerce (50 :: Int)- , _lconfig_importAsColumn = coerce (50 :: Int)- , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3)- , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)- , _lconfig_alignmentLimit = coerce (30 :: Int)- , _lconfig_alignmentBreakOnMultiline = coerce True- , _lconfig_hangingTypeSignature = coerce False- , _lconfig_reformatModulePreamble = coerce True- , _lconfig_allowSingleLineExportList = coerce False- , _lconfig_allowHangingQuasiQuotes = coerce True+ , _conf_layout = LayoutConfig+ { _lconfig_cols = coerce (80 :: Int)+ , _lconfig_indentPolicy = coerce IndentPolicyFree+ , _lconfig_indentAmount = coerce (2 :: Int)+ , _lconfig_indentWhereSpecial = coerce True+ , _lconfig_indentListSpecial = coerce True+ , _lconfig_importColumn = coerce (50 :: Int)+ , _lconfig_importAsColumn = coerce (50 :: Int)+ , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3)+ , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)+ , _lconfig_alignmentLimit = coerce (30 :: Int)+ , _lconfig_alignmentBreakOnMultiline = coerce True+ , _lconfig_hangingTypeSignature = coerce False+ , _lconfig_reformatModulePreamble = coerce True+ , _lconfig_allowSingleLineExportList = coerce False+ , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False+ -- , _lconfig_allowSinglelineRecord = coerce False }- , _conf_errorHandling = ErrorHandlingConfig+ , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = coerce False , _econf_Werror = coerce False , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline , _econf_omit_output_valid_check = coerce False }- , _conf_preprocessor = PreProcessorConfig+ , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = coerce CPPModeAbort , _ppconf_hackAroundIncludes = coerce False }- , _conf_forward = ForwardOptions- { _options_ghc = Identity []- }- , _conf_roundtrip_exactprint_only = coerce False- , _conf_obfuscate = coerce False+ , _conf_forward = ForwardOptions { _options_ghc = Identity [] }+ , _conf_roundtrip_exactprint_only = coerce False+ , _conf_disable_formatting = coerce False+ , _conf_obfuscate = coerce False } forwardOptionsSyntaxExtsEnabled :: ForwardOptions forwardOptionsSyntaxExtsEnabled = ForwardOptions { _options_ghc = Identity- [ "-XLambdaCase"- , "-XMultiWayIf"- , "-XGADTs"- , "-XPatternGuards"- , "-XViewPatterns"- , "-XTupleSections"- , "-XExplicitForAll"- , "-XImplicitParams"- , "-XQuasiQuotes"- , "-XTemplateHaskell"- , "-XBangPatterns"- , "-XTypeApplications"- ]+ [ "-XLambdaCase"+ , "-XMultiWayIf"+ , "-XGADTs"+ , "-XPatternGuards"+ , "-XViewPatterns"+ , "-XTupleSections"+ , "-XExplicitForAll"+ , "-XImplicitParams"+ , "-XQuasiQuotes"+ , "-XTemplateHaskell"+ , "-XBangPatterns"+ , "-XTypeApplications"+ ] } --- brittany-next-binding --columns=200+-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 } cmdlineConfigParser :: CmdParser Identity out (CConfig Option) cmdlineConfigParser = do -- TODO: why does the default not trigger; ind never should be []!!@@ -129,28 +133,24 @@ dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par")- dumpBriDocFloating <- addSimpleBoolFlag ""- ["dump-bridoc-floating"]- (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating")- dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns")- 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")+ dumpBriDocFloating <- addSimpleBoolFlag "" ["dump-bridoc-floating"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating")+ dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns")+ 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)")- wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors")- omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)")+ 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 (debugging)") - roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)")+ roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") - optionsGhc <- addFlagStringParams ""- ["ghc-options"]- "STRING"- (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.")- obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.")+ optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.")+ disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.")+ obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") return $ Config- { _conf_version = mempty- , _conf_debug = DebugConfig+ { _conf_version = mempty+ , _conf_debug = DebugConfig { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST@@ -164,39 +164,36 @@ , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal , _dconf_roundtrip_exactprint_only = mempty }- , _conf_layout = LayoutConfig- { _lconfig_cols = optionConcat cols- , _lconfig_indentPolicy = mempty- , _lconfig_indentAmount = optionConcat ind- , _lconfig_indentWhereSpecial = mempty -- falseToNothing _- , _lconfig_indentListSpecial = mempty -- falseToNothing _- , _lconfig_importColumn = optionConcat importCol- , _lconfig_importAsColumn = optionConcat importAsCol- , _lconfig_altChooser = mempty- , _lconfig_columnAlignMode = mempty- , _lconfig_alignmentLimit = mempty- , _lconfig_alignmentBreakOnMultiline = mempty- , _lconfig_hangingTypeSignature = mempty- , _lconfig_reformatModulePreamble = mempty- , _lconfig_allowSingleLineExportList = mempty- , _lconfig_allowHangingQuasiQuotes = mempty+ , _conf_layout = LayoutConfig+ { _lconfig_cols = optionConcat cols+ , _lconfig_indentPolicy = mempty+ , _lconfig_indentAmount = optionConcat ind+ , _lconfig_indentWhereSpecial = mempty -- falseToNothing _+ , _lconfig_indentListSpecial = mempty -- falseToNothing _+ , _lconfig_importColumn = optionConcat importCol+ , _lconfig_importAsColumn = optionConcat importAsCol+ , _lconfig_altChooser = mempty+ , _lconfig_columnAlignMode = mempty+ , _lconfig_alignmentLimit = mempty+ , _lconfig_alignmentBreakOnMultiline = mempty+ , _lconfig_hangingTypeSignature = mempty+ , _lconfig_reformatModulePreamble = mempty+ , _lconfig_allowSingleLineExportList = mempty+ , _lconfig_allowHangingQuasiQuotes = mempty , _lconfig_experimentalSemicolonNewlines = mempty+ -- , _lconfig_allowSinglelineRecord = mempty }- , _conf_errorHandling = ErrorHandlingConfig+ , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors , _econf_Werror = wrapLast $ falseToNothing wError , _econf_ExactPrintFallback = mempty , _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck }- , _conf_preprocessor = PreProcessorConfig- { _ppconf_CPPMode = mempty- , _ppconf_hackAroundIncludes = mempty- }- , _conf_forward = ForwardOptions- { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ]- }- , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly- , _conf_obfuscate = wrapLast $ falseToNothing obfuscate+ , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty }+ , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] }+ , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly+ , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting+ , _conf_obfuscate = wrapLast $ falseToNothing obfuscate } where falseToNothing = Option . Bool.bool Nothing (Just True)@@ -260,19 +257,21 @@ userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" let searchDirs = [userBritPathSimple, userBritPathXdg]- globalConfig <- Directory.findFileWith Directory.doesFileExist searchDirs "config.yaml"+ globalConfig <- Directory.findFileWith Directory.doesFileExist+ searchDirs+ "config.yaml" maybe (writeUserConfig userBritPathXdg) pure globalConfig- where- writeUserConfig dir = do- let createConfPath = dir FilePath.</> "config.yaml"- liftIO $ Directory.createDirectoryIfMissing True dir- writeDefaultConfig $ createConfPath- pure createConfPath+ where+ writeUserConfig dir = do+ let createConfPath = dir FilePath.</> "config.yaml"+ liftIO $ Directory.createDirectoryIfMissing True dir+ writeDefaultConfig $ createConfPath+ pure createConfPath -- | Searches for a local (per-project) brittany config starting from a given directory findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath) findLocalConfigPath dir = do- let dirParts = FilePath.splitDirectories dir+ let dirParts = FilePath.splitDirectories dir -- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts) Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml"@@ -284,7 +283,8 @@ -> MaybeT IO Config readConfigs cmdlineConfig configPaths = do configs <- readConfig `mapM` configPaths- let merged = Semigroup.sconcat $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs)+ let merged = Semigroup.sconcat+ $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) return $ cZipWith fromOptionIdentity staticDefaultConfig merged -- | Reads provided configs@@ -304,7 +304,6 @@ staticDefaultConfig showConfigYaml :: Config -> String-showConfigYaml = Data.ByteString.Char8.unpack- . Data.Yaml.encode- . cMap (\(Identity x) -> Just x)+showConfigYaml = Data.ByteString.Char8.unpack . Data.Yaml.encode . cMap+ (\(Identity x) -> Just x)
src/Language/Haskell/Brittany/Internal/Config/Types.hs view
@@ -142,6 +142,14 @@ -- The implementation for this is a bit hacky and not tested; it might -- break output syntax or not work properly for every kind of brace. So -- far I have considered `do` and `case-of`.+ -- , _lconfig_allowSinglelineRecord :: f (Last Bool)+ -- -- if true, layouts record data decls as a single line when possible, e.g.+ -- -- > MyPoint { x :: Double, y :: Double }+ -- -- if false, always use the multi-line layout+ -- -- > MyPoint+ -- -- > { x :: Double+ -- -- > , y :: Double+ -- -- > } } deriving (Generic) @@ -179,11 +187,17 @@ , _conf_forward :: CForwardOptions f , _conf_preprocessor :: CPreProcessorConfig f , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool)- , _conf_obfuscate :: f (Semigroup.Last Bool) -- ^ this field is somewhat of a duplicate of the one in DebugConfig. -- It is used for per-declaration disabling by the inline config -- implementation. Could have re-used the existing field, but felt risky -- to use a "debug" labeled field for non-debug functionality.+ , _conf_disable_formatting :: f (Semigroup.Last Bool)+ -- ^ Used for inline config that disables brittany entirely for this+ -- module. Useful for wildcard application+ -- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something+ -- in that direction).+ , _conf_obfuscate :: f (Semigroup.Last Bool)+ } deriving (Generic)
src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs view
@@ -120,6 +120,7 @@ <*> v .:?= Text.pack "conf_forward" <*> v .:?= Text.pack "conf_preprocessor" <*> v .:? Text.pack "conf_roundtrip_exactprint_only"+ <*> v .:? Text.pack "conf_disable_formatting" <*> v .:? Text.pack "conf_obfuscate" parseJSON invalid = Aeson.typeMismatch "Config" invalid
src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs view
@@ -123,7 +123,7 @@ dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str case res of- Left (span, err) -> ExceptT.throwE $ show span ++ ": " ++ err+ Left (span, err) -> ExceptT.throwE $ showOutputable span ++ ": " ++ err Right (a , m ) -> pure (a, m, dynCheckRes)
src/Language/Haskell/Brittany/Internal/LayouterBasics.hs view
@@ -13,6 +13,7 @@ , filterAnns , docEmpty , docLit+ , docLitS , docAlt , CollectAltM , addAlternativeCond@@ -39,6 +40,7 @@ , docAnnotationRest , docMoveToKWDP , docNonBottomSpacing+ , docNonBottomSpacingS , docSetParSpacing , docForceParSpacing , docDebug@@ -60,9 +62,11 @@ , docTick , spacifyDocs , briDocMToPPM+ , briDocMToPPMInner , allocateNode , docSharedWrapper , hasAnyCommentsBelow+ , hasCommentsBetween , hasAnyCommentsConnected , hasAnyCommentsPrior , hasAnyRegularCommentsConnected@@ -296,6 +300,25 @@ List.any (\(c, _) -> ExactPrint.commentIdentifier c > l) <$> astConnectedComments ast +hasCommentsBetween+ :: Data ast+ => GHC.Located ast+ -> AnnKeywordId+ -> AnnKeywordId+ -> ToBriDocM Bool+hasCommentsBetween ast leftKey rightKey = do+ mAnn <- astAnn ast+ let go1 [] = False+ go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest+ go1 (_ : rest) = go1 rest+ go2 [] = False+ go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True+ go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False+ go2 (_ : rest) = go2 rest+ case mAnn of+ Nothing -> pure False+ Just ann -> pure $ go1 $ ExactPrint.annsDP ann+ -- | True if there are any comments that are connected to any node below (in AST -- sense) the given node hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool@@ -481,6 +504,9 @@ docLit :: Text -> ToBriDocM BriDocNumbered docLit t = allocateNode $ BDFLit t +docLitS :: String -> ToBriDocM BriDocNumbered+docLitS s = allocateNode $ BDFLit $ Text.pack s+ docExt :: (ExactPrint.Annotate.Annotate ast) => Located ast@@ -572,8 +598,11 @@ docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered-docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm+docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing False =<< bdm +docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docNonBottomSpacingS bdm = allocateNode . BDFNonBottomSpacing True =<< bdm+ docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm @@ -642,18 +671,18 @@ class DocWrapable a where docWrapNode :: ( Data.Data.Data ast) => Located ast- -> ToBriDocM a- -> ToBriDocM a+ -> a+ -> a docWrapNodePrior :: ( Data.Data.Data ast) => Located ast- -> ToBriDocM a- -> ToBriDocM a+ -> a+ -> a docWrapNodeRest :: ( Data.Data.Data ast) => Located ast- -> ToBriDocM a- -> ToBriDocM a+ -> a+ -> a -instance DocWrapable BriDocNumbered where+instance DocWrapable (ToBriDocM BriDocNumbered) where docWrapNode ast bdm = do bd <- bdm i1 <- allocNodeIndex@@ -679,7 +708,22 @@ $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd -instance DocWrapable a => DocWrapable [a] where+instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where+ docWrapNode ast bdms = case bdms of+ [] -> []+ [bd] -> [docWrapNode ast bd]+ (bd1:bdR) | (bdN:bdM) <- reverse bdR ->+ [docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN]+ _ -> error "cannot happen (TM)"+ docWrapNodePrior ast bdms = case bdms of+ [] -> []+ [bd] -> [docWrapNodePrior ast bd]+ (bd1:bdR) -> docWrapNodePrior ast bd1 : bdR+ docWrapNodeRest ast bdms = case reverse bdms of+ [] -> []+ (bdN:bdR) -> reverse $ docWrapNodeRest ast bdN : bdR++instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where docWrapNode ast bdsm = do bds <- bdsm case bds of@@ -707,7 +751,7 @@ bdN' <- docWrapNodeRest ast (return bdN) return $ reverse (bdN':bdR) -instance DocWrapable a => DocWrapable (Seq a) where+instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where docWrapNode ast bdsm = do bds <- bdsm case Seq.viewl bds of@@ -735,7 +779,7 @@ bdN' <- docWrapNodeRest ast (return bdN) return $ bdR Seq.|> bdN' -instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where+instance DocWrapable (ToBriDocM ([BriDocNumbered], BriDocNumbered, a)) where docWrapNode ast stuffM = do (bds, bd, x) <- stuffM if null bds@@ -791,6 +835,13 @@ briDocMToPPM :: ToBriDocM a -> PPMLocal a briDocMToPPM m = do+ (x, errs, debugs) <- briDocMToPPMInner m+ mTell debugs+ mTell errs+ return x++briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String)+briDocMToPPMInner m = do readers <- MultiRWSS.mGetRawR let ((x, errs), debugs) = runIdentity@@ -800,9 +851,7 @@ $ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterAW $ m- mTell debugs- mTell errs- return x+ pure (x, errs, debugs) docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y) docSharedWrapper f x = return <$> f x
+ src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs view
@@ -0,0 +1,527 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE KindSignatures #-}++module Language.Haskell.Brittany.Internal.Layouters.DataDecl+ ( layoutDataDecl+ )+where++++#include "prelude.inc"++import Language.Haskell.Brittany.Internal.Types+import Language.Haskell.Brittany.Internal.LayouterBasics+import Language.Haskell.Brittany.Internal.Config.Types++import RdrName ( RdrName(..) )+import GHC ( Located, runGhc, GenLocated(L), moduleNameString )+import qualified GHC+import HsSyn+import Name+import BasicTypes+import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey )++import Language.Haskell.Brittany.Internal.Layouters.Type+import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr+import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt+import Language.Haskell.Brittany.Internal.Layouters.Pattern+import Language.Haskell.Brittany.Internal.Utils++import Bag ( mapBagM )++++layoutDataDecl+ :: Located (TyClDecl GhcPs)+ -> Located RdrName+ -> LHsQTyVars GhcPs+ -> HsDataDefn GhcPs+ -> ToBriDocM BriDocNumbered+#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+layoutDataDecl _ _ (XLHsQTyVars ext) _ = absurdExt ext+layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of+#else+layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of+#endif+ -- newtype MyType a b = MyType ..+#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+ HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of+ (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) ->+#else+ HsDataDefn NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of+ (L _ (ConDeclH98 consName Nothing (Just (L _ [])) details _conDoc)) ->+#endif+ docWrapNode ltycl $ do+ nameStr <- lrdrNameToTextAnn name+ consNameStr <- lrdrNameToTextAnn consName+ tyVarLine <- fmap return $ createBndrDoc bndrs+ -- headDoc <- fmap return $ docSeq+ -- [ appSep $ docLitS "newtype")+ -- , appSep $ docLit nameStr+ -- , appSep tyVarLine+ -- ]+ rhsDoc <- fmap return $ createDetailsDoc consNameStr details+ createDerivingPar mDerivs $ docSeq+ [ appSep $ docLitS "newtype"+ , appSep $ docLit nameStr+ , appSep tyVarLine+ , docSeparator+ , docLitS "="+ , docSeparator+ , rhsDoc+ ]+ _ -> briDocByExactNoComment ltycl+++ -- data MyData a b+ -- (zero constructors)+#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+ HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs ->+#else+ HsDataDefn DataType (L _ lhsContext) _ctype Nothing [] mDerivs ->+#endif+ docWrapNode ltycl $ do+ lhsContextDoc <- docSharedWrapper createContextDoc lhsContext+ nameStr <- lrdrNameToTextAnn name+ tyVarLine <- fmap return $ createBndrDoc bndrs+ createDerivingPar mDerivs $ docSeq+ [ appSep $ docLitS "data"+ , lhsContextDoc+ , appSep $ docLit nameStr+ , appSep tyVarLine+ ]++ -- data MyData = MyData ..+ -- data MyData = MyData { .. }+#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+ HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs ->+#else+ HsDataDefn DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs ->+#endif+ case cons of+#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+ (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) ->+#else+ (L _ (ConDeclH98 consName (Just (HsQTvs _ qvars _)) mRhsContext details _conDoc)) ->+#endif+ docWrapNode ltycl $ do+ lhsContextDoc <- docSharedWrapper createContextDoc lhsContext+ nameStr <- lrdrNameToTextAnn name+ consNameStr <- lrdrNameToTextAnn consName+ tyVarLine <- fmap return $ createBndrDoc bndrs+ forallDocMay <- case createForallDoc qvars of+ Nothing -> pure Nothing+ Just x -> Just . pure <$> x+ rhsContextDocMay <- case mRhsContext of+ Nothing -> pure Nothing+ Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt+ rhsDoc <- fmap return $ createDetailsDoc consNameStr details+ consDoc <- fmap pure+ $ docNonBottomSpacing+ $ case (forallDocMay, rhsContextDocMay) of+ (Just forallDoc, Just rhsContextDoc) -> docLines+ [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc]+ , docSeq+ [ docLitS "."+ , docSeparator+ , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc]+ ]+ ]+ (Just forallDoc, Nothing) -> docLines+ [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc]+ , docSeq [docLitS ".", docSeparator, rhsDoc]+ ]+ (Nothing, Just rhsContextDoc) -> docSeq+ [ docLitS "="+ , docSeparator+ , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc]+ ]+ (Nothing, Nothing) -> docSeq [docLitS "=", docSeparator, rhsDoc]+ createDerivingPar mDerivs $ docAlt+ [ -- data D = forall a . Show a => D a+ docSeq+ [ docNodeAnnKW ltycl (Just GHC.AnnData)+ $ docSeq+ [ appSep $ docLitS "data"+ , docForceSingleline $ lhsContextDoc+ , appSep $ docLit nameStr+ , appSep tyVarLine+ , docSeparator+ ]+ , docLitS "="+ , docSeparator+ , docSetIndentLevel $ docSeq+ [ case forallDocMay of+ Nothing -> docEmpty+ Just forallDoc -> docSeq+ [ docForceSingleline forallDoc+ , docSeparator+ , docLitS "."+ , docSeparator+ ]+ , maybe docEmpty docForceSingleline rhsContextDocMay+ , rhsDoc+ ]+ ]+ , -- data D+ -- = forall a . Show a => D a+ docAddBaseY BrIndentRegular $ docPar+ ( docNodeAnnKW ltycl (Just GHC.AnnData)+ $ docSeq+ [ appSep $ docLitS "data"+ , docForceSingleline lhsContextDoc+ , appSep $ docLit nameStr+ , tyVarLine+ ]+ )+ ( docSeq+ [ docLitS "="+ , docSeparator+ , docSetIndentLevel $ docSeq+ [ case forallDocMay of+ Nothing -> docEmpty+ Just forallDoc -> docSeq+ [ docForceSingleline forallDoc+ , docSeparator+ , docLitS "."+ , docSeparator+ ]+ , maybe docEmpty docForceSingleline rhsContextDocMay+ , rhsDoc+ ]+ ]+ )+ , -- data D+ -- = forall a+ -- . Show a =>+ -- D a+ docAddBaseY BrIndentRegular $ docPar+ ( docNodeAnnKW ltycl (Just GHC.AnnData)+ $ docSeq+ [ appSep $ docLitS "data"+ , docForceSingleline lhsContextDoc+ , appSep $ docLit nameStr+ , tyVarLine+ ]+ )+ consDoc+ , -- data+ -- Show a =>+ -- D+ -- = forall a+ -- . Show a =>+ -- D a+ -- This alternative is only for -XDatatypeContexts.+ -- But I think it is rather unlikely this will trigger without+ -- -XDataTypeContexts, especially with the `docNonBottomSpacing`+ -- above, so while not strictly necessary, this should not+ -- hurt.+ docAddBaseY BrIndentRegular $ docPar+ (docLitS "data")+ ( docLines+ [ lhsContextDoc+ , docNodeAnnKW ltycl (Just GHC.AnnData)+ $ docSeq+ [ appSep $ docLit nameStr+ , tyVarLine+ ]+ , consDoc+ ]+ )+ ]+ _ -> briDocByExactNoComment ltycl++ _ -> briDocByExactNoComment ltycl++createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered+createContextDoc [] = docEmpty+createContextDoc [t] =+ docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator]+createContextDoc (t1 : tR) = do+ t1Doc <- docSharedWrapper layoutType t1+ tRDocs <- tR `forM` docSharedWrapper layoutType+ docAlt+ [ docSeq+ [ docLitS "("+ , docForceSingleline $ docSeq $ List.intersperse docCommaSep+ (t1Doc : tRDocs)+ , docLitS ") =>"+ , docSeparator+ ]+ , docLines $ join+ [ [docSeq [docLitS "(", docSeparator, t1Doc]]+ , tRDocs+ <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc]+ , [docLitS ") =>", docSeparator]+ ]+ ]++createBndrDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered+createBndrDoc bs = do+ tyVarDocs <- bs `forM` \case+#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+ (L _ (UserTyVar _ext vname)) -> return $ (lrdrNameToText vname, Nothing)+ (L _ (KindedTyVar _ext lrdrName kind)) -> do+#else+ (L _ (UserTyVar vname)) -> return $ (lrdrNameToText vname, Nothing)+ (L _ (KindedTyVar lrdrName kind)) -> do+#endif+ d <- docSharedWrapper layoutType kind+ return $ (lrdrNameToText lrdrName, Just $ d)+#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+ (L _ (XTyVarBndr ext)) -> absurdExt ext+#endif+ docSeq+ $ List.intersperse docSeparator+ $ tyVarDocs+ <&> \(vname, mKind) -> case mKind of+ Nothing -> docLit vname+ Just kind -> docSeq+ [ docLitS "("+ , docLit vname+ , docSeparator+ , docLitS "::"+ , docSeparator+ , kind+ , docLitS ")"+ ]++createDerivingPar+ :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+createDerivingPar derivs mainDoc = do+ case derivs of+#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */+ (L _ []) -> mainDoc+ (L _ types) ->+ docPar mainDoc+ $ docEnsureIndent BrIndentRegular+ $ docLines+ $ docWrapNode derivs+ $ derivingClauseDoc+ <$> types+#else+ Nothing -> mainDoc+ Just types ->+ docPar mainDoc+ $ docEnsureIndent BrIndentRegular+ $ derivingClauseDoc types+#endif++#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */+derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered+#else+derivingClauseDoc :: Located [LHsSigType GhcPs] -> ToBriDocM BriDocNumbered+#endif+#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+derivingClauseDoc (L _ (XHsDerivingClause ext)) = absurdExt ext+derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of+#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */+derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of+#else+derivingClauseDoc types = case types of+#endif+ (L _ []) -> docSeq []+ (L _ ts) ->+ let+ tsLength = length ts+ whenMoreThan1Type val =+ if tsLength > 1 then docLitS val else docLitS ""+#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */+ (lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy+#else+ (lhsStrategy, rhsStrategy) = (docEmpty, docEmpty)+#endif+ in+ docSeq+ [ docDeriving+ , docWrapNodePrior types $ lhsStrategy+ , docSeparator+ , whenMoreThan1Type "("+ , docWrapNodeRest types+ $ docSeq+ $ List.intersperse docCommaSep+ $ ts <&> \case+#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+ HsIB _ t -> layoutType t+ XHsImplicitBndrs x -> absurdExt x+#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */+ HsIB _ t _ -> layoutType t+#else+ HsIB _ t -> layoutType t+#endif+ , whenMoreThan1Type ")"+ , rhsStrategy+ ]+#if MIN_VERSION_ghc(8,2,0) /* ghc-8.6 */+ where+ strategyLeftRight = \case+ (L _ StockStrategy ) -> (docLitS " stock", docEmpty)+ (L _ AnyclassStrategy ) -> (docLitS " anyclass", docEmpty)+ (L _ NewtypeStrategy ) -> (docLitS " newtype", docEmpty)+#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+ lVia@(L _ (ViaStrategy viaTypes) ) ->+ ( docEmpty+ , case viaTypes of+ HsIB _ext t -> docSeq+ [ docWrapNode lVia $ docLitS " via"+ , docSeparator+ , layoutType t+ ]+ XHsImplicitBndrs ext -> absurdExt ext+ )+#endif+#endif++docDeriving :: ToBriDocM BriDocNumbered+docDeriving = docLitS "deriving"++createDetailsDoc+ :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered)+createDetailsDoc consNameStr details = case details of+ PrefixCon args -> do+ indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack+ let+ singleLine = docSeq+ [ docLit consNameStr+ , docSeparator+ , docForceSingleline+ $ docSeq+ $ List.intersperse docSeparator+ $ args <&> layoutType+ ]+ leftIndented = docSetParSpacing+ . docAddBaseY BrIndentRegular+ . docPar (docLit consNameStr)+ . docLines+ $ layoutType <$> args+ multiAppended = docSeq+ [ docLit consNameStr+ , docSeparator+ , docSetBaseY $ docLines $ layoutType <$> args+ ]+ multiIndented = docSetBaseY $ docAddBaseY BrIndentRegular $ docPar+ (docLit consNameStr)+ (docLines $ layoutType <$> args)+ case indentPolicy of+ IndentPolicyLeft -> docAlt [singleLine, leftIndented]+ IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented]+ IndentPolicyFree ->+ docAlt [singleLine, multiAppended, multiIndented, leftIndented]+ RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"]+ RecCon lRec@(L _ fields@(_:_)) -> do+ let ((fName1, fType1) : fDocR) = mkFieldDocs fields+ -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack+ let allowSingleline = False+ docAddBaseY BrIndentRegular+ $ runFilteredAlternative+ $ do+ -- single-line: { i :: Int, b :: Bool }+ addAlternativeCond allowSingleline $ docSeq+ [ docLit consNameStr+ , docSeparator+ , docWrapNodePrior lRec $ docLitS "{"+ , docSeparator+ , docWrapNodeRest lRec+ $ docForceSingleline+ $ docSeq+ $ join+ $ [fName1, docSeparator, docLitS "::", docSeparator, fType1]+ : [ [ docLitS ","+ , docSeparator+ , fName+ , docSeparator+ , docLitS "::"+ , docSeparator+ , fType+ ]+ | (fName, fType) <- fDocR+ ]+ , docSeparator+ , docLitS "}"+ ]+ addAlternative $ docPar+ (docLit consNameStr)+ (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines+ [ docAlt+ [ docCols ColRecDecl+ [ appSep (docLitS "{")+ , appSep $ docForceSingleline fName1+ , docSeq [docLitS "::", docSeparator]+ , docForceSingleline $ fType1+ ]+ , docSeq+ [ docLitS "{"+ , docSeparator+ , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar+ fName1+ (docSeq [docLitS "::", docSeparator, fType1])+ ]+ ]+ , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) ->+ docAlt+ [ docCols ColRecDecl+ [ docCommaSep+ , appSep $ docForceSingleline fName+ , docSeq [docLitS "::", docSeparator]+ , docForceSingleline fType+ ]+ , docSeq+ [ docLitS ","+ , docSeparator+ , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar+ fName+ (docSeq [docLitS "::", docSeparator, fType])+ ]+ ]+ , docLitS "}"+ ]+ )+ InfixCon arg1 arg2 -> docSeq+ [ layoutType arg1+ , docSeparator+ , docLit consNameStr+ , docSeparator+ , layoutType arg2+ ]+ where+ mkFieldDocs+ :: [LConDeclField GhcPs]+ -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)]+ mkFieldDocs = fmap $ \lField -> case lField of+#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+ L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t+ L _ (XConDeclField x) -> absurdExt x+#else+ L _ (ConDeclField names t _) -> createNamesAndTypeDoc lField names t+#endif++createForallDoc :: [LHsTyVarBndr GhcPs] -> Maybe (ToBriDocM BriDocNumbered)+createForallDoc [] = Nothing+createForallDoc lhsTyVarBndrs = Just $ docSeq+ [docLitS "forall ", createBndrDoc lhsTyVarBndrs]++createNamesAndTypeDoc+ :: Data.Data.Data ast+ => Located ast+ -> [GenLocated t (FieldOcc GhcPs)]+ -> Located (HsType GhcPs)+ -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)+createNamesAndTypeDoc lField names t =+ ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq+ [ docSeq+ $ List.intersperse docCommaSep+ $ names+ <&> \case+#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+ L _ (XFieldOcc x) -> absurdExt x+ L _ (FieldOcc _ fieldName) ->+#else+ L _ (FieldOcc fieldName _) ->+#endif+ docLit =<< lrdrNameToTextAnn fieldName+ ]+ , docWrapNodeRest lField $ layoutType t+ )
src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ViewPatterns #-} module Language.Haskell.Brittany.Internal.Layouters.Decl ( layoutDecl@@ -53,6 +56,7 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt import Language.Haskell.Brittany.Internal.Layouters.Pattern+import Language.Haskell.Brittany.Internal.Layouters.DataDecl import Bag ( mapBagM, bagToList, emptyBag ) import Data.Char (isUpper)@@ -68,7 +72,7 @@ Right n -> return n TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) InstD _ (TyFamInstD _ tfid) ->- withTransformedAnns d $ layoutTyFamInstDecl False (L loc tfid)+ withTransformedAnns d $ layoutTyFamInstDecl False d tfid InstD _ (ClsInstD _ inst) -> withTransformedAnns d $ layoutClsInst (L loc inst) _ -> briDocByExactNoComment d@@ -80,12 +84,11 @@ Right n -> return n TyClD tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) InstD (TyFamInstD tfid) ->- withTransformedAnns d $ layoutTyFamInstDecl False (L loc tfid)+ withTransformedAnns d $ layoutTyFamInstDecl False d tfid InstD (ClsInstD inst) -> withTransformedAnns d $ layoutClsInst (L loc inst) _ -> briDocByExactNoComment d #endif - -------------------------------------------------------------------------------- -- Sig --------------------------------------------------------------------------------@@ -93,11 +96,11 @@ layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */- TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType names typ+ TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ #elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */- TypeSig names (HsWC _ (HsIB _ typ _)) -> layoutNamesAndType names typ+ TypeSig names (HsWC _ (HsIB _ typ _)) -> layoutNamesAndType Nothing names typ #else /* ghc-8.0 */- TypeSig names (HsIB _ (HsWC _ _ typ)) -> layoutNamesAndType names typ+ TypeSig names (HsIB _ (HsWC _ _ typ)) -> layoutNamesAndType Nothing names typ #endif #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) ->@@ -121,15 +124,25 @@ <> nameStr <> Text.pack " #-}" #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */- ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType names typ+ ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ #elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */- ClassOpSig False names (HsIB _ typ _) -> layoutNamesAndType names typ+ ClassOpSig False names (HsIB _ typ _) -> layoutNamesAndType Nothing names typ #else /* ghc-8.0 */- ClassOpSig False names (HsIB _ typ) -> layoutNamesAndType names typ+ ClassOpSig False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ #endif+#if MIN_VERSION_ghc(8,6,0)+ PatSynSig _ names (HsIB _ typ) -> layoutNamesAndType (Just "pattern") names typ+#elif MIN_VERSION_ghc(8,2,0)+ PatSynSig names (HsIB _ typ _) -> layoutNamesAndType (Just "pattern") names typ+#else+ PatSynSig name (HsIB _ typ) -> layoutNamesAndType (Just "pattern") [name] typ+#endif _ -> briDocByExactNoComment lsig -- TODO where- layoutNamesAndType names typ = docWrapNode lsig $ do+ layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do+ let keyDoc = case mKeyword of+ Just key -> [appSep . docLit $ Text.pack key]+ Nothing -> [] nameStrs <- names `forM` lrdrNameToTextAnn let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs typeDoc <- docSharedWrapper layoutType typ@@ -139,8 +152,8 @@ .> _lconfig_hangingTypeSignature .> confUnpack if shouldBeHanging- then docSeq- [ appSep $ docWrapNodeRest lsig $ docLit nameStr+ then docSeq $+ [ appSep $ docWrapNodeRest lsig $ docSeq $ keyDoc <> [docLit nameStr] , docSetBaseY $ docLines [ docCols ColTyOpPrefix@@ -151,7 +164,7 @@ ] else layoutLhsAndType hasComments- (appSep . docWrapNodeRest lsig $ docLit nameStr)+ (appSep . docWrapNodeRest lsig . docSeq $ keyDoc <> [docLit nameStr]) "::" typeDoc @@ -231,8 +244,18 @@ clauseDocs mWhereArg hasComments+#if MIN_VERSION_ghc(8,8,0)+ PatSynBind _ (PSB _ patID lpat rpat dir) -> do+#elif MIN_VERSION_ghc(8,6,0)+ PatSynBind _ (PSB _ patID lpat rpat dir) -> do+#else+ PatSynBind (PSB patID _ lpat rpat dir) -> do+#endif+ fmap Right $ docWrapNode lbind $ layoutPatSynBind patID+ lpat+ dir+ rpat _ -> Right <$> unknownNodeError "" lbind- layoutIPBind :: ToBriDoc IPBind layoutIPBind lipbind@(L _ bind) = case bind of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */@@ -511,7 +534,9 @@ (ColBindingLine alignmentToken) [ docSeq (patPartInline ++ [guardPart]) , docSeq- [appSep $ return binderDoc, docForceParSpacing $ return body]+ [ appSep $ return binderDoc+ , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body+ ] ] ] ++ wherePartMultiLine@@ -709,7 +734,100 @@ ] ++ wherePartMultiLine +-- | Layout a pattern synonym binding+layoutPatSynBind+ :: Located (IdP GhcPs)+ -> HsPatSynDetails (Located (IdP GhcPs))+ -> HsPatSynDir GhcPs+ -> LPat GhcPs+ -> ToBriDocM BriDocNumbered+layoutPatSynBind name patSynDetails patDir rpat = do+ let patDoc = docLit $ Text.pack "pattern"+ binderDoc = case patDir of+ ImplicitBidirectional -> docLit $ Text.pack "="+ _ -> docLit $ Text.pack "<-"+ body = colsWrapPat =<< layoutPat rpat+ whereDoc = docLit $ Text.pack "where"+ mWhereDocs <- layoutPatSynWhere patDir+ headDoc <- fmap pure $ docSeq $+ [ patDoc+ , docSeparator+ , layoutLPatSyn name patSynDetails+ , docSeparator+ , binderDoc+ ]+ runFilteredAlternative $ do+ addAlternative $+ -- pattern .. where+ -- ..+ -- ..+ docAddBaseY BrIndentRegular $ docSeq+ ( [headDoc, docSeparator, body]+ ++ case mWhereDocs of+ Just ds -> [docSeparator, docPar whereDoc (docLines ds)]+ Nothing -> []+ )+ addAlternative $+ -- pattern .. =+ -- ..+ -- pattern .. <-+ -- .. where+ -- ..+ -- ..+ docAddBaseY BrIndentRegular $ docPar+ headDoc+ (case mWhereDocs of+ Nothing -> body+ Just ds -> docLines ([ docSeq [body, docSeparator, whereDoc] ] ++ ds)+ ) +-- | Helper method for the left hand side of a pattern synonym+layoutLPatSyn+ :: Located (IdP GhcPs)+ -> HsPatSynDetails (Located (IdP GhcPs))+ -> ToBriDocM BriDocNumbered+#if MIN_VERSION_ghc(8,4,0)+layoutLPatSyn name (PrefixCon vars) = do+#else+layoutLPatSyn name (PrefixPatSyn vars) = do+#endif+ docName <- lrdrNameToTextAnn name+ names <- mapM lrdrNameToTextAnn vars+ docSeq . fmap appSep $ docLit docName : (docLit <$> names)+#if MIN_VERSION_ghc(8,4,0)+layoutLPatSyn name (InfixCon left right) = do+#else+layoutLPatSyn name (InfixPatSyn left right) = do+#endif+ leftDoc <- lrdrNameToTextAnn left+ docName <- lrdrNameToTextAnn name+ rightDoc <- lrdrNameToTextAnn right+ docSeq . fmap (appSep . docLit) $ [leftDoc, docName, rightDoc]+#if MIN_VERSION_ghc(8,4,0)+layoutLPatSyn name (RecCon recArgs) = do+#else+layoutLPatSyn name (RecordPatSyn recArgs) = do+#endif+ docName <- lrdrNameToTextAnn name+ args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs+ docSeq . fmap docLit+ $ [docName, Text.pack " { " ]+ <> intersperse (Text.pack ", ") args+ <> [Text.pack " }"]++-- | Helper method to get the where clause from of explicitly bidirectional+-- pattern synonyms+layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered])+layoutPatSynWhere hs = case hs of+#if MIN_VERSION_ghc(8,6,0)+ ExplicitBidirectional (MG _ (L _ lbinds) _) -> do+#else+ ExplicitBidirectional (MG (L _ lbinds) _ _ _) -> do+#endif+ binderDoc <- docLit $ Text.pack "="+ Just <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds+ _ -> pure Nothing+ -------------------------------------------------------------------------------- -- TyClDecl --------------------------------------------------------------------------------@@ -741,6 +859,14 @@ let wrapNodeRest = docWrapNodeRest ltycl docWrapNodePrior ltycl $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ+#if MIN_VERSION_ghc(8,6,0)+ DataDecl _ext name tyVars _ dataDefn ->+#elif MIN_VERSION_ghc(8,2,0)+ DataDecl name tyVars _ dataDefn _ _ ->+#else+ DataDecl name tyVars dataDefn _ _ ->+#endif+ layoutDataDecl ltycl name tyVars dataDefn _ -> briDocByExactNoComment ltycl layoutSynDecl@@ -817,39 +943,39 @@ -layoutTyFamInstDecl :: Bool -> ToBriDoc TyFamInstDecl-layoutTyFamInstDecl inClass (L loc tfid) = do+layoutTyFamInstDecl+ :: Data.Data.Data a+ => Bool+ -> Located a+ -> TyFamInstDecl GhcPs+ -> ToBriDocM BriDocNumbered+layoutTyFamInstDecl inClass outerNode tfid = do let #if MIN_VERSION_ghc(8,8,0)- linst = L loc (TyFamInstD NoExt tfid)- feqn@(FamEqn _ name bndrsMay pats _fixity typ) = hsib_body $ tfid_eqn tfid+ FamEqn _ name bndrsMay pats _fixity typ = hsib_body $ tfid_eqn tfid -- bndrsMay isJust e.g. with -- type instance forall a . MyType (Maybe a) = Either () a- lfeqn = L loc feqn+ innerNode = outerNode #elif MIN_VERSION_ghc(8,6,0)- linst = L loc (TyFamInstD NoExt tfid)- feqn@(FamEqn _ name pats _fixity typ) = hsib_body $ tfid_eqn tfid+ FamEqn _ name pats _fixity typ = hsib_body $ tfid_eqn tfid bndrsMay = Nothing- lfeqn = L loc feqn+ innerNode = outerNode #elif MIN_VERSION_ghc(8,4,0)- linst = L loc (TyFamInstD tfid)- feqn@(FamEqn name pats _fixity typ) = hsib_body $ tfid_eqn tfid+ FamEqn name pats _fixity typ = hsib_body $ tfid_eqn tfid bndrsMay = Nothing- lfeqn = L loc feqn+ innerNode = outerNode #elif MIN_VERSION_ghc(8,2,0)- linst = L loc (TyFamInstD tfid)- lfeqn@(L _ (TyFamEqn name boundPats _fixity typ)) = tfid_eqn tfid+ innerNode@(L _ (TyFamEqn name boundPats _fixity typ)) = tfid_eqn tfid bndrsMay = Nothing pats = hsib_body boundPats #else- linst = L loc (TyFamInstD tfid)- lfeqn@(L _ (TyFamEqn name boundPats typ)) = tfid_eqn tfid+ innerNode@(L _ (TyFamEqn name boundPats typ)) = tfid_eqn tfid bndrsMay = Nothing pats = hsib_body boundPats #endif- docWrapNodePrior linst $ do+ docWrapNodePrior outerNode $ do nameStr <- lrdrNameToTextAnn name- needsParens <- hasAnnKeyword lfeqn AnnOpenP+ needsParens <- hasAnnKeyword outerNode AnnOpenP let instanceDoc = if inClass then docLit $ Text.pack "type"@@ -863,9 +989,7 @@ ++ processTyVarBndrsSingleline bndrDocs ) lhs =- docWrapNode lfeqn- . appSep- . docWrapNodeRest linst+ docWrapNode innerNode . docSeq $ [appSep instanceDoc] ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ]@@ -874,8 +998,8 @@ ++ intersperse docSeparator (layoutHsTyPats pats) ++ [ docParenR | needsParens ] hasComments <- (||)- <$> hasAnyRegularCommentsConnected lfeqn- <*> hasAnyRegularCommentsRest linst+ <$> hasAnyRegularCommentsConnected outerNode+ <*> hasAnyRegularCommentsRest innerNode typeDoc <- docSharedWrapper layoutType typ layoutLhsAndType hasComments lhs "=" typeDoc @@ -961,8 +1085,8 @@ layoutAndLocateTyFamInsts :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered)- layoutAndLocateTyFamInsts ltfid@(L loc _) =- L loc <$> layoutTyFamInstDecl True ltfid+ layoutAndLocateTyFamInsts ltfid@(L loc tfid) =+ L loc <$> layoutTyFamInstDecl True ltfid tfid layoutAndLocateDataFamInsts :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered)@@ -1029,6 +1153,7 @@ | otherwise -> st : go lineR isTypeOrData t' = (Text.pack "type" `Text.isPrefixOf` t')+ || (Text.pack "newtype" `Text.isPrefixOf` t') || (Text.pack "data" `Text.isPrefixOf` t') @@ -1043,13 +1168,12 @@ -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered layoutLhsAndType hasComments lhs sep typeDoc = do- let sepDoc = appSep . docLit $ Text.pack sep runFilteredAlternative $ do -- (separators probably are "=" or "::") -- lhs = type -- lhs :: type- addAlternativeCond (not hasComments)- $ docSeq [lhs, sepDoc, docForceSingleline typeDoc]+ addAlternativeCond (not hasComments) $ docSeq+ [lhs, docSeparator, docLitS sep, docSeparator, docForceSingleline typeDoc] -- lhs -- :: typeA -- -> typeB@@ -1058,4 +1182,6 @@ -- -> typeB addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols ColTyOpPrefix- [sepDoc, docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc]+ [ appSep $ docLitS sep+ , docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc+ ]
src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs view
@@ -426,6 +426,9 @@ (_, L _ (HsApp _ (L _ HsVar{}))) -> False _ -> True #endif+ let leftIsDoBlock = case expLeft of+ L _ HsDo{} -> True+ _ -> False runFilteredAlternative $ do -- one-line addAlternative@@ -442,16 +445,17 @@ -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight -- ] -- two-line- addAlternative- $ docAddBaseY BrIndentRegular- $ docPar- expDocLeft -- TODO: this is not forced to single-line, which has- -- certain.. interesting consequences.- -- At least, the "two-line" label is not entirely- -- accurate.- ( docForceSingleline+ addAlternative $ do+ let+ expDocOpAndRight = docForceSingleline $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight]- )+ if leftIsDoBlock+ then docLines [expDocLeft, expDocOpAndRight]+ else docAddBaseY BrIndentRegular $ docPar expDocLeft expDocOpAndRight+ -- TODO: in both cases, we don't force expDocLeft to be+ -- single-line, which has certain.. interesting consequences.+ -- At least, the "two-line" label is not entirely+ -- accurate. -- one-line + par addAlternativeCond allowPar $ docSeq@@ -460,11 +464,13 @@ , docForceParSpacing expDocRight ] -- more lines- addAlternative- $ docAddBaseY BrIndentRegular- $ docPar- expDocLeft- (docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight])+ addAlternative $ do+ let expDocOpAndRight =+ docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight]+ if leftIsDoBlock+ then docLines [expDocLeft, expDocOpAndRight]+ else docAddBaseY BrIndentRegular+ $ docPar expDocLeft expDocOpAndRight #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ NegApp _ op _ -> do #else@@ -528,7 +534,10 @@ argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM- hasComments <- hasAnyCommentsBelow lexpr+ hasComments <- orM+ ( hasCommentsBetween lexpr AnnOpenP AnnCloseP+ : map hasAnyCommentsBelow args+ ) let (openLit, closeLit) = case boxity of Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") Unboxed -> (docParenHashLSep, docParenHashRSep)@@ -770,7 +779,7 @@ addAlternativeCond (not hasComments) $ docSeq [ appSep $ docLit $ Text.pack "let" , docNodeAnnKW lexpr (Just AnnLet)- $ appSep $ docForceSingleline bindDoc+ $ appSep $ docForceSingleline bindDoc , appSep $ docLit $ Text.pack "in" , docForceSingleline expDoc1 ]@@ -1223,7 +1232,7 @@ -- } addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq- [ docNodeAnnKW lexpr Nothing $ appSep nameDoc+ [ docNodeAnnKW lexpr Nothing $ docForceSingleline $ appSep nameDoc , docSetBaseY $ docLines $ let line1 = docCols ColRec [ appSep $ docLit $ Text.pack "{"
src/Language/Haskell/Brittany/Internal/Layouters/IE.hs view
@@ -65,29 +65,36 @@ #else IEThingWith x _ ns _ -> do #endif- hasComments <- hasAnyCommentsBelow lie+ hasComments <- orM+ ( hasCommentsBetween lie AnnOpenP AnnCloseP+ : hasAnyCommentsBelow x+ : map hasAnyCommentsBelow ns+ ) runFilteredAlternative $ do addAlternativeCond (not hasComments) $ docSeq $ [layoutWrapped lie x, docLit $ Text.pack "("] ++ intersperse docCommaSep (map nameDoc ns) ++ [docParenR]- addAlternative $ docAddBaseY BrIndentRegular $ docPar- (layoutWrapped lie x)- (layoutItems (splitFirstLast ns))+ addAlternative+ $ docWrapNodeRest lie+ $ docAddBaseY BrIndentRegular+ $ docPar+ (layoutWrapped lie x)+ (layoutItems (splitFirstLast ns)) where nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] layoutItems FirstLastEmpty = docSetBaseY $ docLines- [docSeq [docParenLSep, docWrapNodeRest lie docEmpty], docParenR]+ [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR] layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines- [docSeq [docParenLSep, docWrapNodeRest lie $ nameDoc n], docParenR]+ [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n], docParenR] layoutItems (FirstLast n1 nMs nN) = docSetBaseY $ docLines $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] ++ map layoutItem nMs- ++ [docSeq [docCommaSep, docWrapNodeRest lie $ nameDoc nN], docParenR]+ ++ [docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN], docParenR] #if MIN_VERSION_ghc(8,6,0) IEModuleContents _ n -> docSeq #else
src/Language/Haskell/Brittany/Internal/Layouters/Module.hs view
@@ -49,6 +49,7 @@ , docWrapNode lmod $ appSep $ case les of Nothing -> docEmpty Just x -> layoutLLIEs True x+ , docSeparator , docLit $ Text.pack "where" ] addAlternative@@ -56,11 +57,13 @@ [ docAddBaseY BrIndentRegular $ docPar (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] )- (docWrapNode lmod $ case les of- Nothing -> docEmpty- Just x -> layoutLLIEs False x+ (docSeq [ docWrapNode lmod $ case les of+ Nothing -> docEmpty+ Just x -> layoutLLIEs False x+ , docSeparator+ , docLit $ Text.pack "where"+ ] )- , docLit $ Text.pack "where" ] ] : map layoutImport imports
src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs view
@@ -51,7 +51,10 @@ [ docCols ColBindStmt [ appSep patDoc- , docSeq [appSep $ docLit $ Text.pack "<-", docForceParSpacing expDoc]+ , docSeq+ [ appSep $ docLit $ Text.pack "<-"+ , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc+ ] ] , docCols ColBindStmt
src/Language/Haskell/Brittany/Internal/Layouters/Type.hs view
@@ -14,6 +14,10 @@ import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics+import Language.Haskell.Brittany.Internal.Utils+ ( splitFirstLast+ , FirstLastView(..)+ ) import GHC ( runGhc , GenLocated(L)@@ -444,15 +448,17 @@ docs <- docSharedWrapper layoutType `mapM` typs let end = docLit $ Text.pack ")" lines = List.tail docs <&> \d ->- docCols ColTyOpPrefix [docCommaSep, d]+ docAddBaseY (BrIndentSpecial 2)+ $ docCols ColTyOpPrefix [docCommaSep, d]+ commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) docAlt [ docSeq $ [docLit $ Text.pack "("]- ++ List.intersperse docCommaSep (docForceSingleline <$> docs)+ ++ docWrapNodeRest ltype commaDocs ++ [end] , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] in docPar (docAddBaseY (BrIndentSpecial 2) $ line1)- (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end])+ (docLines $ docWrapNodeRest ltype lines ++ [end]) ] unboxedL = do docs <- docSharedWrapper layoutType `mapM` typs@@ -460,15 +466,16 @@ end = docParenHashRSep docAlt [ docSeq $ [start]- ++ List.intersperse docCommaSep docs+ ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) ++ [end] , let line1 = docCols ColTyOpPrefix [start, head docs] lines = List.tail docs <&> \d ->- docCols ColTyOpPrefix [docCommaSep, d]+ docAddBaseY (BrIndentSpecial 2)+ $ docCols ColTyOpPrefix [docCommaSep, d] in docPar (docAddBaseY (BrIndentSpecial 2) line1)- (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end])+ (docLines $ lines ++ [end]) ] HsOpTy{} -> -- TODO briDocByExactInlineOnly "HsOpTy{}" ltype@@ -690,12 +697,48 @@ HsExplicitListTy _ typs -> do #endif typDocs <- docSharedWrapper layoutType `mapM` typs+ hasComments <- hasAnyCommentsBelow ltype+ let specialCommaSep = appSep $ docLit $ Text.pack " ," docAlt [ docSeq $ [docLit $ Text.pack "'["]- ++ List.intersperse docCommaSep typDocs+ ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs) ++ [docLit $ Text.pack "]"]- -- TODO+ , case splitFirstLast typDocs of+ FirstLastEmpty -> docSeq+ [ docLit $ Text.pack "'["+ , docNodeAnnKW ltype (Just AnnOpenS) $ docLit $ Text.pack "]"+ ]+ FirstLastSingleton e -> docAlt+ [ docSeq+ [ docLit $ Text.pack "'["+ , docNodeAnnKW ltype (Just AnnOpenS) $ docForceSingleline e+ , docLit $ Text.pack "]"+ ]+ , docSetBaseY $ docLines+ [ docSeq+ [ docLit $ Text.pack "'["+ , docSeparator+ , docSetBaseY $ docNodeAnnKW ltype (Just AnnOpenS) e+ ]+ , docLit $ Text.pack " ]"+ ]+ ]+ FirstLast e1 ems eN -> runFilteredAlternative $ do+ addAlternativeCond (not hasComments)+ $ docSeq+ $ [docLit $ Text.pack "'["]+ ++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN]))+ ++ [docLit $ Text.pack " ]"]+ addAlternative $+ let+ start = docCols ColList+ [appSep $ docLit $ Text.pack "'[", e1]+ linesM = ems <&> \d ->+ docCols ColList [specialCommaSep, d]+ lineN = docCols ColList [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN]+ end = docLit $ Text.pack " ]"+ in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] ] HsExplicitTupleTy{} -> -- TODO briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype
src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs view
@@ -331,7 +331,7 @@ BrIndentNone -> r BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r- BDFNonBottomSpacing bd -> rec bd+ BDFNonBottomSpacing _ bd -> rec bd BDFSetParSpacing bd -> rec bd BDFForceParSpacing bd -> rec bd BDFDebug s bd -> do@@ -488,13 +488,18 @@ BrIndentSpecial i -> i return $ mVs <&> \(VerticalSpacing lsp psp pf) -> VerticalSpacing (lsp + addInd) psp pf- BDFNonBottomSpacing bd -> do+ BDFNonBottomSpacing b bd -> do mVs <- rec bd return $ mVs- <|> LineModeValid (VerticalSpacing 0- (VerticalSpacingParAlways colMax)- False)+ <|> LineModeValid+ (VerticalSpacing+ 0+ (if b then VerticalSpacingParSome 0+ else VerticalSpacingParAlways colMax+ )+ False+ ) BDFSetParSpacing bd -> do mVs <- rec bd return $ mVs <&> \vs -> vs { _vs_parFlag = True }@@ -799,16 +804,30 @@ BrIndentSpecial i -> i return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> VerticalSpacing (lsp + addInd) psp parFlag- BDFNonBottomSpacing bd -> do+ BDFNonBottomSpacing b bd -> do+ -- TODO: the `b` flag is an ugly hack, but I was not able to make+ -- all tests work without it. It should be possible to have+ -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this+ -- problem but breaks certain other cases. mVs <- rec bd return $ if null mVs- then [VerticalSpacing 0 (VerticalSpacingParAlways colMax) False]+ then [VerticalSpacing+ 0+ (if b then VerticalSpacingParSome 0+ else VerticalSpacingParAlways colMax+ )+ False+ ] else mVs <&> \vs -> vs { _vs_sameLine = min colMax (_vs_sameLine vs) , _vs_paragraph = case _vs_paragraph vs of VerticalSpacingParNone -> VerticalSpacingParNone- VerticalSpacingParAlways i -> VerticalSpacingParAlways i- VerticalSpacingParSome i -> VerticalSpacingParAlways i+ VerticalSpacingParAlways i+ | b -> VerticalSpacingParSome 0+ | otherwise -> VerticalSpacingParAlways i+ VerticalSpacingParSome i+ | b -> VerticalSpacingParSome 0+ | otherwise -> VerticalSpacingParAlways i } -- the version below is an alternative idea: fold the input -- spacings into a single spacing. This was hoped to improve in
src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs view
@@ -135,4 +135,4 @@ BDSetParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing BDDebug{} -> Nothing- BDNonBottomSpacing x -> Just x+ BDNonBottomSpacing _ x -> Just x
src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs view
@@ -132,6 +132,8 @@ Just $ BDIndentLevelPop (BDAddBaseY ind x) BDAddBaseY ind (BDIndentLevelPushCur x) -> Just $ BDIndentLevelPushCur (BDAddBaseY ind x)+ BDAddBaseY ind (BDEnsureIndent ind2 x) ->+ Just $ BDEnsureIndent (mergeIndents ind ind2) x _ -> Nothing stepBO :: BriDoc -> BriDoc stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $
src/Language/Haskell/Brittany/Internal/Types.hs view
@@ -84,6 +84,17 @@ -- -- captures if the layouter currently is in a new line, i.e. if the -- -- current line only contains (indentation) spaces. -- this is mostly superseeded by curYOrAddNewline, iirc.+ , _lstate_commentNewlines :: Int -- number of newlines inserted due to+ -- move-to-DP at a start of a comment.+ -- Necessary because some keyword DPs+ -- are relative to the last non-comment+ -- entity (for some reason).+ -- This is not very strictly reset to 0,+ -- so we might in some cases get "artifacts"+ -- from previous document elements.+ -- But the worst effect at the moment would+ -- be that we introduce less newlines on+ -- moveToKWDP, which seems harmless enough. } lstate_baseY :: LayoutState -> Int@@ -102,6 +113,7 @@ ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state) ++ ",commentCol=" ++ show (_lstate_commentCol state) ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state)+ ++ ",commentNewlines=" ++ show (_lstate_commentNewlines state) ++ "}" -- data NewLineState = NewLineStateInit -- initial state. we do not know if in a@@ -185,6 +197,8 @@ | ColBindStmt | ColDoLet -- the non-indented variant | ColRec+ | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect?+ | ColRecDecl | ColListComp | ColList | ColApp Text@@ -201,7 +215,10 @@ | BrIndentSpecial Int deriving (Eq, Ord, Typeable, Data.Data.Data, Show) -type ToBriDocM = MultiRWSS.MultiRWS '[Config, Anns] '[[BrittanyError], Seq String] '[NodeAllocIndex]+type ToBriDocM = MultiRWSS.MultiRWS+ '[Config, Anns] -- reader+ '[[BrittanyError], Seq String] -- writer+ '[NodeAllocIndex] -- state type ToBriDoc (sym :: * -> *) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered@@ -256,7 +273,7 @@ -- after the alt transformation. | BDForceMultiline BriDoc | BDForceSingleline BriDoc- | BDNonBottomSpacing BriDoc+ | BDNonBottomSpacing Bool BriDoc | BDSetParSpacing BriDoc | BDForceParSpacing BriDoc -- pseudo-deprecated@@ -301,7 +318,7 @@ | BDFEnsureIndent BrIndent (f (BriDocF f)) | BDFForceMultiline (f (BriDocF f)) | BDFForceSingleline (f (BriDocF f))- | BDFNonBottomSpacing (f (BriDocF f))+ | BDFNonBottomSpacing Bool (f (BriDocF f)) | BDFSetParSpacing (f (BriDocF f)) | BDFForceParSpacing (f (BriDocF f)) | BDFDebug String (f (BriDocF f))@@ -313,33 +330,37 @@ type BriDocNumbered = (Int, BriDocFInt) instance Uniplate.Uniplate BriDoc where- uniplate x@BDEmpty{} = plate x- uniplate x@BDLit{} = plate x- uniplate (BDSeq list) = plate BDSeq ||* list- uniplate (BDCols sig list) = plate BDCols |- sig ||* list- uniplate x@BDSeparator = plate x- uniplate (BDAddBaseY ind bd) = plate BDAddBaseY |- ind |* bd- uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd- uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd- uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd- uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd- uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented- uniplate (BDAlt alts) = plate BDAlt ||* alts- uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd- uniplate x@BDExternal{} = plate x- uniplate x@BDPlain{} = plate x- uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd- uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd- uniplate (BDAnnotationRest annKey bd) = plate BDAnnotationRest |- annKey |* bd- uniplate (BDMoveToKWDP annKey kw b bd) = plate BDMoveToKWDP |- annKey |- kw |- b |* bd- uniplate (BDLines lines) = plate BDLines ||* lines- uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd- uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd- uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd- uniplate (BDNonBottomSpacing bd) = plate BDNonBottomSpacing |* bd- uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd- uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd- uniplate (BDDebug s bd) = plate BDDebug |- s |* bd+ uniplate x@BDEmpty{} = plate x+ uniplate x@BDLit{} = plate x+ uniplate (BDSeq list ) = plate BDSeq ||* list+ uniplate (BDCols sig list) = plate BDCols |- sig ||* list+ uniplate x@BDSeparator = plate x+ uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd+ uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd+ uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd+ uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd+ uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd+ uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented+ uniplate (BDAlt alts ) = plate BDAlt ||* alts+ uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd+ uniplate x@BDExternal{} = plate x+ uniplate x@BDPlain{} = plate x+ uniplate (BDAnnotationPrior annKey bd) =+ plate BDAnnotationPrior |- annKey |* bd+ uniplate (BDAnnotationKW annKey kw bd) =+ plate BDAnnotationKW |- annKey |- kw |* bd+ uniplate (BDAnnotationRest annKey bd) =+ plate BDAnnotationRest |- annKey |* bd+ uniplate (BDMoveToKWDP annKey kw b bd) =+ plate BDMoveToKWDP |- annKey |- kw |- b |* bd+ uniplate (BDLines lines ) = plate BDLines ||* lines+ uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd+ uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd+ uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd+ uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd+ uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd+ uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd+ uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd newtype NodeAllocIndex = NodeAllocIndex Int @@ -367,14 +388,13 @@ BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd BDFLines lines -> BDLines $ rec <$> lines BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd- BDFForceMultiline bd -> BDForceMultiline $ rec bd- BDFForceSingleline bd -> BDForceSingleline $ rec bd- BDFNonBottomSpacing bd -> BDNonBottomSpacing $ rec bd- BDFSetParSpacing bd -> BDSetParSpacing $ rec bd- BDFForceParSpacing bd -> BDForceParSpacing $ rec bd+ BDFForceMultiline bd -> BDForceMultiline $ rec bd+ BDFForceSingleline bd -> BDForceSingleline $ rec bd+ BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd+ BDFSetParSpacing bd -> BDSetParSpacing $ rec bd+ BDFForceParSpacing bd -> BDForceParSpacing $ rec bd BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd- where- rec = unwrapBriDocNumbered+ where rec = unwrapBriDocNumbered isNotEmpty :: BriDoc -> Bool isNotEmpty BDEmpty = False@@ -404,11 +424,11 @@ BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines BDEnsureIndent _ind bd -> briDocSeqSpine bd- BDForceMultiline bd -> briDocSeqSpine bd- BDForceSingleline bd -> briDocSeqSpine bd- BDNonBottomSpacing bd -> briDocSeqSpine bd- BDSetParSpacing bd -> briDocSeqSpine bd- BDForceParSpacing bd -> briDocSeqSpine bd+ BDForceMultiline bd -> briDocSeqSpine bd+ BDForceSingleline bd -> briDocSeqSpine bd+ BDNonBottomSpacing _ bd -> briDocSeqSpine bd+ BDSetParSpacing bd -> briDocSeqSpine bd+ BDForceParSpacing bd -> briDocSeqSpine bd BDDebug _s bd -> briDocSeqSpine bd briDocForceSpine :: BriDoc -> BriDoc
src/Language/Haskell/Brittany/Internal/Utils.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -25,6 +26,7 @@ , splitFirstLast , lines' , showOutputable+ , absurdExt ) where @@ -57,6 +59,9 @@ import Language.Haskell.Brittany.Internal.Types import qualified Data.Generics.Uniplate.Direct as Uniplate+#if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */+import qualified HsExtension+#endif @@ -293,3 +298,12 @@ (s1, []) -> [s1] (s1, [_]) -> [s1, ""] (s1, (_:r)) -> s1 : lines' r++#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */+-- | A method to dismiss NoExt patterns for total matches+absurdExt :: HsExtension.NoExt -> a+absurdExt = error "cannot construct NoExt"+#else+absurdExt :: ()+absurdExt = ()+#endif
+ src/Language/Haskell/Brittany/Main.hs view
@@ -0,0 +1,484 @@+{-# LANGUAGE DataKinds #-}++module Language.Haskell.Brittany.Main (main) where++++#include "prelude.inc"++-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 }+import qualified Language.Haskell.GHC.ExactPrint as ExactPrint+import qualified Language.Haskell.GHC.ExactPrint.Annotate+ as ExactPrint.Annotate+import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types+import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers+import qualified Data.Map as Map+import qualified Data.Monoid++import GHC ( GenLocated(L) )+import Outputable ( Outputable(..)+ , showSDocUnsafe+ )++import Text.Read ( Read(..) )+import qualified Text.ParserCombinators.ReadP as ReadP+import qualified Text.ParserCombinators.ReadPrec as ReadPrec+import qualified Data.Text.Lazy.Builder as Text.Builder++import Control.Monad ( zipWithM )+import Data.CZipWith++import qualified Debug.Trace as Trace++import Language.Haskell.Brittany.Internal.Types+import Language.Haskell.Brittany.Internal+import Language.Haskell.Brittany.Internal.Config+import Language.Haskell.Brittany.Internal.Config.Types+import Language.Haskell.Brittany.Internal.Utils+import Language.Haskell.Brittany.Internal.Obfuscation++import qualified Text.PrettyPrint as PP++import DataTreePrint+import UI.Butcher.Monadic++import qualified System.Exit+import qualified System.Directory as Directory+import qualified System.FilePath.Posix as FilePath++import qualified DynFlags as GHC+import qualified GHC.LanguageExtensions.Type as GHC++import Paths_brittany++++data WriteMode = Display | Inplace++instance Read WriteMode where+ readPrec = val "display" Display <|> val "inplace" Inplace+ where val iden v = ReadPrec.lift $ ReadP.string iden >> return v++instance Show WriteMode where+ show Display = "display"+ show Inplace = "inplace"+++main :: IO ()+main = mainFromCmdParserWithHelpDesc mainCmdParser++helpDoc :: PP.Doc+helpDoc = PP.vcat $ List.intersperse+ (PP.text "")+ [ parDocW+ [ "Reformats one or more haskell modules."+ , "Currently affects only the module head (imports/exports), type"+ , "signatures and function bindings;"+ , "everything else is left unmodified."+ , "Based on ghc-exactprint, thus (theoretically) supporting all"+ , "that ghc does."+ ]+ , parDoc $ "Example invocations:"+ , PP.hang (PP.text "") 2 $ PP.vcat+ [ PP.text "brittany"+ , PP.nest 2 $ PP.text "read from stdin, output to stdout"+ ]+ , PP.hang (PP.text "") 2 $ PP.vcat+ [ PP.text "brittany --indent=4 --write-mode=inplace *.hs"+ , PP.nest 2 $ PP.vcat+ [ PP.text "run on all modules in current directory (no backup!)"+ , PP.text "4 spaces indentation"+ ]+ ]+ , parDocW+ [ "This program is written carefully and contains safeguards to ensure"+ , "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."+ ]+ , parDoc $ "There is NO WARRANTY, to the extent permitted by law."+ , parDocW+ [ "This program is free software released under the AGPLv3."+ , "For details use the --license flag."+ ]+ , parDoc $ "See https://github.com/lspitzner/brittany"+ , parDoc+ $ "Please report bugs at"+ ++ " https://github.com/lspitzner/brittany/issues"+ ]++licenseDoc :: PP.Doc+licenseDoc = PP.vcat $ List.intersperse+ (PP.text "")+ [ parDoc $ "Copyright (C) 2016-2019 Lennart Spitzner"+ , parDoc $ "Copyright (C) 2019 PRODA LTD"+ , parDocW+ [ "This program is free software: you can redistribute it and/or modify"+ , "it under the terms of the GNU Affero General Public License,"+ , "version 3, as published by the Free Software Foundation."+ ]+ , parDocW+ [ "This program is distributed in the hope that it will be useful,"+ , "but WITHOUT ANY WARRANTY; without even the implied warranty of"+ , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the"+ , "GNU Affero General Public License for more details."+ ]+ , parDocW+ [ "You should have received a copy of the GNU Affero General Public"+ , "License along with this program. If not, see"+ , "<http://www.gnu.org/licenses/>."+ ]+ ]+++mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) ()+mainCmdParser helpDesc = do+ addCmdSynopsis "haskell source pretty printer"+ addCmdHelp $ helpDoc+ -- addCmd "debugArgs" $ do+ addHelpCommand helpDesc+ addCmd "license" $ addCmdImpl $ print $ licenseDoc+ -- addButcherDebugCommand+ reorderStart+ printHelp <- addSimpleBoolFlag "h" ["help"] mempty+ printVersion <- addSimpleBoolFlag "" ["version"] mempty+ printLicense <- addSimpleBoolFlag "" ["license"] mempty+ noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty+ configPaths <- addFlagStringParams ""+ ["config-file"]+ "PATH"+ (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?+ cmdlineConfig <- cmdlineConfigParser+ suppressOutput <- addSimpleBoolFlag+ ""+ ["suppress-output"]+ (flagHelp $ parDoc+ "suppress the regular output, i.e. the transformed haskell source"+ )+ _verbosity <- addSimpleCountFlag+ "v"+ ["verbose"]+ (flagHelp $ parDoc "[currently without effect; TODO]")+ checkMode <- addSimpleBoolFlag+ "c"+ ["check-mode"]+ (flagHelp+ (PP.vcat+ [ PP.text "check for changes but do not write them out"+ , PP.text "exits with code 0 if no changes necessary, 1 otherwise"+ , PP.text "and print file path(s) of files that have changes to stdout"+ ]+ )+ )+ writeMode <- addFlagReadParam+ ""+ ["write-mode"]+ "(display|inplace)"+ ( flagHelp+ (PP.vcat+ [ PP.text "display: output for any input(s) goes to stdout"+ , PP.text "inplace: override respective input file (without backup!)"+ ]+ )+ Data.Monoid.<> flagDefault Display+ )+ inputParams <- addParamNoFlagStrings+ "PATH"+ (paramHelpStr "paths to input/inout haskell source files")+ reorderStop+ addCmdImpl $ void $ do+ when printLicense $ do+ print licenseDoc+ System.Exit.exitSuccess+ when printVersion $ do+ do+ putStrLn $ "brittany version " ++ showVersion version+ putStrLn $ "Copyright (C) 2016-2019 Lennart Spitzner"+ putStrLn $ "Copyright (C) 2019 PRODA LTD"+ putStrLn $ "There is NO WARRANTY, to the extent permitted by law."+ System.Exit.exitSuccess+ when printHelp $ do+ 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+ let outputPaths = case writeMode of+ Display -> repeat Nothing+ Inplace -> inputPaths++ configsToLoad <- liftIO $ if null configPaths+ then+ maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath)+ else pure configPaths++ config <-+ runMaybeT+ (if noUserConfig+ then readConfigs cmdlineConfig configsToLoad+ else readConfigsWithUserConfig cmdlineConfig configsToLoad+ )+ >>= \case+ Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53)+ Just x -> return x+ when (config & _conf_debug & _dconf_dump_config & confUnpack)+ $ trace (showConfigYaml config)+ $ return ()++ results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode)+ inputPaths+ outputPaths++ if checkMode+ then when (any (== Changes) (Data.Either.rights results))+ $ System.Exit.exitWith (System.Exit.ExitFailure 1)+ else case results of+ xs | all Data.Either.isRight xs -> pure ()+ [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x)+ _ -> System.Exit.exitWith (System.Exit.ExitFailure 1)+++data ChangeStatus = Changes | NoChanges+ deriving (Eq)++-- | The main IO parts for the default mode of operation, and after commandline+-- and config stuff is processed.+coreIO+ :: (String -> IO ()) -- ^ error output function. In parallel operation, you+ -- may want serialize the different outputs and+ -- consequently not directly print to stderr.+ -> Config -- ^ global program config.+ -> Bool -- ^ whether to supress output (to stdout). Purely IO flag, so+ -- currently not part of program config.+ -> Bool -- ^ whether we are (just) in check mode.+ -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing.+ -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing.+ -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status.+coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =+ ExceptT.runExceptT $ do+ let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO ()+ let ghcOptions = config & _conf_forward & _options_ghc & runIdentity+ -- there is a good of code duplication between the following code and the+ -- `pureModuleTransform` function. Unfortunately, there are also a good+ -- amount of slight differences: This module is a bit more verbose, and+ -- it tries to use the full-blown `parseModule` function which supports+ -- CPP (but requires the input to be a file..).+ let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack+ -- the flag will do the following: insert a marker string+ -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with+ -- "#include" before processing (parsing) input; and remove that marker+ -- string from the transformation output.+ -- The flag is intentionally misspelled to prevent clashing with+ -- inline-config stuff.+ let hackAroundIncludes =+ config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack+ let exactprintOnly = viaGlobal || viaDebug+ where+ viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack+ viaDebug =+ config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack++ let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags+ then case cppMode of+ CPPModeAbort -> do+ return $ Left "Encountered -XCPP. Aborting."+ CPPModeWarn -> do+ putErrorLnIO+ $ "Warning: Encountered -XCPP."+ ++ " Be warned that -XCPP is not supported and that"+ ++ " brittany cannot check that its output is syntactically"+ ++ " valid in its presence."+ return $ Right True+ CPPModeNowarn -> return $ Right True+ else return $ Right False+ (parseResult, originalContents) <- case inputPathM of+ Nothing -> do+ -- TODO: refactor this hack to not be mixed into parsing logic+ let hackF s = if "#include" `isPrefixOf` s+ then "-- BRITANY_INCLUDE_HACK " ++ s+ else s+ let hackTransform = if hackAroundIncludes && not exactprintOnly+ then List.intercalate "\n" . fmap hackF . lines'+ else id+ inputString <- liftIO $ System.IO.hGetContents System.IO.stdin+ parseRes <- liftIO $ parseModuleFromString ghcOptions+ "stdin"+ cppCheckFunc+ (hackTransform inputString)+ return (parseRes, Text.pack inputString)+ Just p -> liftIO $ do+ parseRes <- parseModule ghcOptions p cppCheckFunc+ inputText <- Text.IO.readFile p+ -- The above means we read the file twice, but the+ -- GHC API does not really expose the source it+ -- read. Should be in cache still anyways.+ --+ -- We do not use TextL.IO.readFile because lazy IO is evil.+ -- (not identical -> read is not finished ->+ -- handle still open -> write below crashes - evil.)+ return (parseRes, inputText)+ case parseResult of+ Left left -> do+ putErrorLn "parse error:"+ putErrorLn left+ ExceptT.throwE 60+ Right (anns, parsedSource, hasCPP) -> do+ (inlineConf, perItemConf) <-+ case+ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)+ of+ Left (err, input) -> do+ putErrorLn $ "Error: parse error in inline configuration:"+ putErrorLn err+ putErrorLn $ " in the string \"" ++ input ++ "\"."+ ExceptT.throwE 61+ Right c -> -- trace (showTree c) $+ pure c+ let moduleConf = cZipWith fromOptionIdentity config inlineConf+ when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do+ let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource+ trace ("---- ast ----\n" ++ show val) $ return ()+ let disableFormatting =+ moduleConf & _conf_disable_formatting & confUnpack+ (errsWarns, outSText, hasChanges) <- do+ if+ | disableFormatting -> do+ pure ([], originalContents, False)+ | exactprintOnly -> do+ let r = Text.pack $ ExactPrint.exactPrint parsedSource anns+ pure ([], r, r /= originalContents)+ | otherwise -> do+ let omitCheck =+ moduleConf+ & _conf_errorHandling+ .> _econf_omit_output_valid_check+ .> confUnpack+ (ews, outRaw) <- if hasCPP || omitCheck+ then return+ $ pPrintModule moduleConf perItemConf anns parsedSource+ else liftIO $ pPrintModuleAndCheck moduleConf+ perItemConf+ anns+ parsedSource+ let hackF s = fromMaybe s $ TextL.stripPrefix+ (TextL.pack "-- BRITANY_INCLUDE_HACK ")+ s+ let out = TextL.toStrict $ if hackAroundIncludes+ then+ TextL.intercalate (TextL.pack "\n")+ $ fmap hackF+ $ TextL.splitOn (TextL.pack "\n") outRaw+ else outRaw+ out' <- if moduleConf & _conf_obfuscate & confUnpack+ then lift $ obfuscate out+ else pure out+ pure $ (ews, out', out' /= originalContents)+ let customErrOrder ErrorInput{} = 4+ customErrOrder LayoutWarning{} = -1 :: Int+ customErrOrder ErrorOutputCheck{} = 1+ customErrOrder ErrorUnusedComment{} = 2+ customErrOrder ErrorUnknownNode{} = -2 :: Int+ customErrOrder ErrorMacroConfig{} = 5+ when (not $ null errsWarns) $ do+ let groupedErrsWarns =+ Data.List.Extra.groupOn customErrOrder+ $ List.sortOn customErrOrder+ $ errsWarns+ groupedErrsWarns `forM_` \case+ (ErrorOutputCheck{} : _) -> do+ putErrorLn+ $ "ERROR: brittany pretty printer"+ ++ " returned syntactically invalid result."+ (ErrorInput str : _) -> do+ putErrorLn $ "ERROR: parse error: " ++ str+ uns@(ErrorUnknownNode{} : _) -> do+ putErrorLn+ $ "WARNING: encountered unknown syntactical constructs:"+ uns `forM_` \case+ ErrorUnknownNode str ast@(L loc _) -> do+ putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc)+ when+ ( config+ & _conf_debug+ & _dconf_dump_ast_unknown+ & confUnpack+ )+ $ do+ putErrorLn $ " " ++ show (astToDoc ast)+ _ -> error "cannot happen (TM)"+ putErrorLn+ " -> falling back on exactprint for this element of the module"+ warns@(LayoutWarning{} : _) -> do+ putErrorLn $ "WARNINGS:"+ warns `forM_` \case+ LayoutWarning str -> putErrorLn str+ _ -> error "cannot happen (TM)"+ unused@(ErrorUnusedComment{} : _) -> do+ putErrorLn+ $ "Error: detected unprocessed comments."+ ++ " The transformation output will most likely"+ ++ " not contain some of the comments"+ ++ " present in the input haskell source file."+ putErrorLn $ "Affected are the following comments:"+ unused `forM_` \case+ ErrorUnusedComment str -> putErrorLn str+ _ -> error "cannot happen (TM)"+ (ErrorMacroConfig err input : _) -> do+ putErrorLn $ "Error: parse error in inline configuration:"+ putErrorLn err+ putErrorLn $ " in the string \"" ++ input ++ "\"."+ [] -> error "cannot happen"+ -- TODO: don't output anything when there are errors unless user+ -- adds some override?+ let+ hasErrors =+ case config & _conf_errorHandling & _econf_Werror & confUnpack of+ False -> 0 < maximum (-1 : fmap customErrOrder errsWarns)+ True -> not $ null errsWarns+ outputOnErrs =+ config+ & _conf_errorHandling+ & _econf_produceOutputOnErrors+ & confUnpack+ shouldOutput =+ not suppressOutput+ && not checkMode+ && (not hasErrors || outputOnErrs)++ when shouldOutput+ $ addTraceSep (_conf_debug config)+ $ case outputPathM of+ Nothing -> liftIO $ Text.IO.putStr $ outSText+ Just p -> liftIO $ do+ let isIdentical = case inputPathM of+ Nothing -> False+ Just _ -> not hasChanges+ unless isIdentical $ Text.IO.writeFile p $ outSText++ when (checkMode && hasChanges) $ case inputPathM of+ Nothing -> pure ()+ Just p -> liftIO $ putStrLn $ "formatting would modify: " ++ p++ when hasErrors $ ExceptT.throwE 70+ return (if hasChanges then Changes else NoChanges)+ where+ addTraceSep conf =+ if or+ [ confUnpack $ _dconf_dump_annotations conf+ , confUnpack $ _dconf_dump_ast_unknown conf+ , confUnpack $ _dconf_dump_ast_full conf+ , confUnpack $ _dconf_dump_bridoc_raw conf+ , confUnpack $ _dconf_dump_bridoc_simpl_alt conf+ , confUnpack $ _dconf_dump_bridoc_simpl_floating conf+ , confUnpack $ _dconf_dump_bridoc_simpl_columns conf+ , confUnpack $ _dconf_dump_bridoc_simpl_indent conf+ , confUnpack $ _dconf_dump_bridoc_final conf+ ]+ then trace "----"+ else id