diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,44 @@ # Revision history for brittany +## 0.12.0.0 -- June 2019 + +* Support for ghc-8.6 (basic support, not necessarily all new syntactic + extensions) +* Support -XExplicitNamespaces and -XPatternSynonyms +* Allow a --dry-run sort of operation via flag "-c/--check-mode" + (thanks to Doug Beardsley @mightybyte) +* Include file name in errors about unsupported syntax nodes (thanks to @5outh) +* Partially implement layouting class instances: Layouts children, but + falls back on ghc-exactprint for the instance head + (thanks to Rupert Horlick @ruhatch) +* Implement layouting for type synonyms (thanks to Rupert Horlick @ruhatch) +* Support -XMagicHash, -XUnboxedTuples (thanks to Sergey Vinokurov @sergv) +* Support -XQuasiQuotes (no formatting applied to the splices; they are simply + retained without causing the dreaded "Unknown construct: HsSpliceE{}") + - `lconfig_allowHangingQuasiQuotes` controls whether multi-line + QuasiQuotes are allowed to start at the end of the current line, or + whether they are always placed in new lines. +* Bugfixes: + - Fix rare-case alignment bug with IndentPolicyMultiple (#144) + - Make inline layout config apply to module header (#151) + - Fix unaligned import-hiding layout (#150) + - Fix idempotence violation for comments around if-then-else (#167) + - Fix comments having an effect on far-away parent node's layout (#159) + - Fix imports of type operators ("symbolic data types") + (thanks to Phil Hazelden @ChickenProp) + - Work around GHC and cabal-install misfeature ".ghc.environment files" + that could break brittany in unexpected and hard-to-understand ways + - Stop removing empty lines before `where` keyword in a couple of cases + - Fix functions with mixing prefix/infix style causing error (#234) +* Changes to layout: + - Align usage of spaces for record update vs record construction (#126) + - More indentation to import-hiding-paragraph (follow-up to #150 fix) + - Record construction and update now are layouted in the same way + (thanks to Evan Rutledge Borden @eborden) + - Stop allowing single-line layout when there are comments between + arguments (#214) (thanks to @matt-noonan) +* Various build-instructions and editor integrations + ## 0.11.0.0 -- May 2018 * Support for ghc-8.4 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -48,7 +48,7 @@ # Other usage notes -- Supports GHC versions `8.0`, `8.2` and `8.4`. +- Supports GHC versions `8.0`, `8.2`, `8.4`, `8.6`. - 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. @@ -58,37 +58,50 @@ # Installation -- via `cabal` "old-build" +- via `stack` ~~~~.sh + stack install brittany # --resolver lts-10.0 + ~~~~ + + If you use an lts that includes brittany this should just work; otherwise + you may want to clone the repo and try again (there are several stack.yamls + included). + +- via `nix`: + ~~~.sh + nix build -f release.nix # or 'nix-build -f release.nix' + nix-env -i ./result + ~~~ + +- via `cabal v1-build` + + ~~~~.sh # optionally: # mkdir brittany # cd brittany # cabal sandbox init - cabal install brittany --bindir=$HOME/.cabal/bin # -w $PATH_TO_GHC_8_0 + cabal install brittany --bindir=$HOME/.cabal/bin # -w $PATH_TO_GHC_8_x ~~~~ -- via `cabal new-build` +- via `cabal v2-install` ~~~~.sh - cabal unpack brittany - cd brittany-0.11.0.0 - # cabal new-configure -w $PATH_TO_GHC_8_0 - cabal new-build exe:brittany - # and it should be safe to just copy the executable, e.g. - cp `./find dist-newstyle/build/ -type f -name brittany` $HOME/.cabal/bin/ + cabal v2-install brittany ~~~~ -- via `stack` using a sufficiently recent stackage snapshot (dated to >= 2017-11-15) +- via `cabal v2-build`, should v2-install not work: ~~~~.sh - stack install brittany # --resolver lts-10.0 + cabal unpack brittany + cd brittany-0.11.0.0 + # cabal new-configure -w $PATH_TO_GHC_8_x + cabal new-build exe:brittany + # and it should be safe to just copy the executable, e.g. + cp `find dist-newstyle/ -name brittany -type f | xargs -x ls -t | head -n1` $HOME/.cabal/bin/ ~~~~ - (earlier ltss did not include `brittany` yet, but the repo should contain a - `stack.yaml` that works with ghc-8.0.) - -- on ArchLinux via [the britanny AUR package](https://aur.archlinux.org/packages/brittany/) +- on ArchLinux via [the brittany AUR package](https://aur.archlinux.org/packages/brittany/) using `aura`: ~~~~.sh aura -A brittany @@ -109,6 +122,10 @@ #### Neovim / Vim 8 The [Neoformat](https://github.com/sbdchd/neoformat) plugin comes with support for brittany built in. +#### Atom + [Atom Beautify](https://atom.io/packages/atom-beautify) supports brittany as a formatter for Haskell. Since the default formatter is set to hindent, you will need to change this setting to brittany, after installing the extension. +#### Emacs + [format-all](https://github.com/lassik/emacs-format-all-the-code) support brittany as the default formatter for Haskell. # Usage @@ -145,21 +162,30 @@ # Feature Requests, Contribution, Documentation -This currently is a one-person project in the sense that 90% of the code is -written by one person. And (unfortunately) it is not my job to keep improving -this project. Please forgive that as a consequence my time to invest on new -features is rather limited. +For a long time this project has had a single maintainer, and as a consequence +there have been some mildly large delays for reacting to feature requests +and even PRs. -Nonetheless I consider it "in active development" :) +Sorry about that. -One way of speeding things up is to make your own contributions. There is +The good news is that this project is getting sponsored by PRODA LTD, and two +previous contributors, Evan Borden and Taylor Fausak, have agreed on helping +with organisational aspects. Thanks! + +Still, this project has a long queue of very sensible feature requests, so it +may take some time until new ones get our attention. But with the help of +the co-maintainers, at least the reaction-times on PRs and the frequency +of releases should improve significantly. + +If you are interested in making your own contributions, there is a good amount of high-level documentation at [the documentation index](doc/implementation/index.md) # License -Copyright (C) 2016-2018 Lennart Spitzner +Copyright (C) 2016-2019 Lennart Spitzner\ +Copyright (C) 2019 PRODA LTD This program is free software: you can redistribute it and/or modify it under the terms of the diff --git a/brittany.cabal b/brittany.cabal --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.11.0.0 +version: 0.12.0.0 synopsis: Haskell source code formatter description: { See . @@ -12,7 +12,8 @@ license-file: LICENSE author: Lennart Spitzner maintainer: Lennart Spitzner -copyright: Copyright (C) 2016-2018 Lennart Spitzner +copyright: Copyright (C) 2016-2019 Lennart Spitzner + Copyright (C) 2019 PRODA LTD category: Language build-type: Simple cabal-version: 1.18 @@ -25,6 +26,7 @@ } extra-source-files: { src-literatetests/*.blt + srcinc/prelude.inc } source-repository head { @@ -42,9 +44,8 @@ Haskell2010 hs-source-dirs: src - install-includes: { - srcinc/prelude.inc - } + include-dirs: + srcinc exposed-modules: { Language.Haskell.Brittany Language.Haskell.Brittany.Internal @@ -83,12 +84,12 @@ -fno-warn-redundant-constraints } build-depends: - { base >=4.9 && <4.12 - , ghc >=8.0.1 && <8.5 + { base >=4.9 && <4.13 + , ghc >=8.0.1 && <8.7 , ghc-paths >=0.1.0.9 && <0.2 - , ghc-exactprint >=0.5.6.0 && <0.5.7 + , ghc-exactprint >=0.5.8 && <0.6.2 , transformers >=0.5.2.0 && <0.6 - , containers >=0.5.7.1 && <0.6 + , containers >=0.5.7.1 && <0.7 , mtl >=2.2.1 && <2.3 , text >=1.2 && <1.3 , multistate >=0.7.1.1 && <0.9 @@ -99,19 +100,19 @@ , 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.9 - , aeson >=1.0.1.0 && <1.3 + , yaml >=0.8.18 && <0.12 + , aeson >=1.0.1.0 && <1.5 , extra >=1.4.10 && <1.7 , uniplate >=1.6.12 && <1.7 , strict >=0.3.2 && <0.4 - , monad-memo >=0.4.1 && <0.5 + , monad-memo >=0.4.1 && <0.6 , unsafe >=0.0 && <0.1 , safe >=0.3.9 && <0.4 , deepseq >=1.4.2.0 && <1.5 , semigroups >=0.18.2 && <0.19 , cmdargs >=0.10.14 && <0.11 , czipwith >=1.0.1.0 && <1.1 - , ghc-boot-th >=8.0.1 && <8.5 + , ghc-boot-th >=8.0.1 && <8.7 , filepath >=1.4.1.0 && <1.5 , random >= 1.1 && <1.2 } @@ -130,8 +131,6 @@ MultiWayIf KindSignatures } - include-dirs: - srcinc } executable brittany @@ -179,6 +178,7 @@ , filepath >=1.4.1.0 && <1.5 } hs-source-dirs: src-brittany + include-dirs: srcinc default-language: Haskell2010 default-extensions: { CPP @@ -243,12 +243,13 @@ , cmdargs , czipwith , ghc-boot-th - , hspec >=2.4.1 && <2.6 + , hspec >=2.4.1 && <2.8 } main-is: TestMain.hs other-modules: TestUtils AsymptoticPerfTests hs-source-dirs: src-unittests + include-dirs: srcinc default-extensions: { CPP @@ -269,6 +270,10 @@ -fno-warn-unused-imports -rtsopts -with-rtsopts "-M2G" + -threaded + -- ^ threaded is not necessary at all, but our CI trusts on being able + -- to pass -N1, which is not possible without threaded :-/ + -- (plus -no-threaded is not a thing, afaict) } test-suite littests @@ -310,13 +315,14 @@ , cmdargs , czipwith , ghc-boot-th - , hspec >=2.4.1 && <2.6 + , hspec >=2.4.1 && <2.8 , filepath , parsec >=3.1.11 && <3.2 } main-is: Main.hs other-modules: hs-source-dirs: src-literatetests + include-dirs: srcinc default-extensions: { CPP @@ -335,8 +341,9 @@ ghc-options: { -Wall -fno-warn-unused-imports + -threaded -rtsopts - -with-rtsopts "-M2G" + -with-rtsopts "-M2G -N" } test-suite libinterfacetests @@ -352,11 +359,12 @@ , base , text , transformers - , hspec >=2.4.1 && <2.6 + , hspec >=2.4.1 && <2.8 } main-is: Main.hs other-modules: hs-source-dirs: src-libinterfacetests + include-dirs: srcinc default-extensions: { FlexibleContexts FlexibleInstances @@ -371,4 +379,8 @@ -fno-warn-unused-imports -rtsopts -with-rtsopts "-M2G" + -threaded + -- ^ threaded is not necessary at all, but our CI trusts on being able + -- to pass -N1, which is not possible without threaded :-/ + -- (plus -no-threaded is not a thing, afaict) } diff --git a/doc/implementation/theory.md b/doc/implementation/theory.md --- a/doc/implementation/theory.md +++ b/doc/implementation/theory.md @@ -1,6 +1,6 @@ # Introduction -[The readme](../../master/README.md) mentions a couple of goals for this +[The readme](../../README.md) mentions a couple of goals for this project, including the following two: - Be clever about using the available horizontal space while not overflowing diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -6,22 +6,29 @@ #include "prelude.inc" -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 +-- 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.Map as Map import qualified Data.Monoid -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 GHC ( GenLocated(L) ) +import Outputable ( Outputable(..) + , showSDocUnsafe + ) -import Control.Monad (zipWithM) +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 qualified Debug.Trace as Trace import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal @@ -30,21 +37,22 @@ import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Obfuscation -import qualified Text.PrettyPrint as PP +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 System.Directory as Directory +import qualified System.FilePath.Posix as FilePath -import qualified DynFlags as GHC -import qualified GHC.LanguageExtensions.Type as GHC +import qualified DynFlags as GHC +import qualified GHC.LanguageExtensions.Type as GHC -import Paths_brittany +import Paths_brittany + data WriteMode = Display | Inplace instance Read WriteMode where @@ -73,16 +81,16 @@ ] , 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.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" - ] + [ 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." @@ -93,9 +101,14 @@ , "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."] + , 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" + , parDoc + $ "Please report bugs at" + ++ " https://github.com/lspitzner/brittany/issues" ] licenseDoc :: PP.Doc @@ -130,29 +143,49 @@ addCmd "license" $ addCmdImpl $ print $ licenseDoc -- addButcherDebugCommand reorderStart - printHelp <- addSimpleBoolFlag "h" ["help"] mempty - printVersion <- addSimpleBoolFlag "" ["version"] mempty - printLicense <- addSimpleBoolFlag "" ["license"] mempty - configPaths <- addFlagStringParams "" ["config-file"] "PATH" (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? + printHelp <- addSimpleBoolFlag "h" ["help"] mempty + printVersion <- addSimpleBoolFlag "" ["version"] mempty + printLicense <- addSimpleBoolFlag "" ["license"] 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]") - writeMode <- addFlagReadParam + (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 + ( 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") + inputParams <- addParamNoFlagStrings + "PATH" + (paramHelpStr "paths to input/inout haskell source files") reorderStop addCmdImpl $ void $ do when printLicense $ do @@ -165,31 +198,48 @@ 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 + 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 inputPaths = + if null inputParams then [Nothing] else map Just inputParams let outputPaths = case writeMode of - Display -> repeat Nothing - Inplace -> inputPaths + Display -> repeat Nothing + Inplace -> inputPaths configsToLoad <- liftIO $ if null configPaths - then maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) - else pure configPaths + then + maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) + else pure configPaths - config <- runMaybeT (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 () + config <- + runMaybeT (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) inputPaths outputPaths - 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) + 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 @@ -201,26 +251,33 @@ -- 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 ()) -- ^ Either an errorNo, or success. -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 = (config & _conf_roundtrip_exactprint_only & confUnpack) - || (config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack) - let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + -> 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." @@ -233,117 +290,163 @@ return $ Right True CPPModeNowarn -> return $ Right True else return $ Right False - parseResult <- 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 - liftIO $ parseModuleFromString ghcOptions "stdin" cppCheckFunc (hackTransform inputString) - Just p -> liftIO $ parseModule ghcOptions p cppCheckFunc - case parseResult of - Left left -> do - putErrorLn "parse error:" - putErrorLn $ show left - ExceptT.throwE 60 - Right (anns, parsedSource, hasCPP) -> do - inlineConf <- 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 - 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 = config & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack - (ews, outRaw) <- if hasCPP || omitCheck - then return $ pPrintModule config inlineConf anns parsedSource - else liftIO $ pPrintModuleAndCheck config inlineConf 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 + (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 config & _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 -> do - putErrorLn str - 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 + 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) - when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPathM of - Nothing -> liftIO $ Text.IO.putStr $ outSText - Just p -> liftIO $ do - isIdentical <- case inputPathM of - Nothing -> pure False - Just path -> do - (== outSText) <$> Text.IO.readFile path - -- 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.) - unless isIdentical $ Text.IO.writeFile p $ outSText + 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 + when hasErrors $ ExceptT.throwE 70 + return (if noChanges then NoChanges else Changes) where addTraceSep conf = if or diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -516,8 +516,61 @@ func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd) +#test comment-after-then +foo = if True + then + -- iiiiii + "a " + else + "b " +#test comment-after-if-else-do +func = if cond + then pure 42 + else do + -- test + abc +#test nonempty-case-short +func = case x of + False -> False + True -> True + +#test nonempty-case-long +func = + case + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + of + False -> False + True -> True + +#test nonempty-case-long-do +func = do + case + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + of + False -> False + True -> True + +#test empty-case-short +func = case x of {} + +#test empty-case-long +func = + case + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + of {} + +#test empty-case-long-do +func = do + case + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + of {} + ############################################################################### ############################################################################### ############################################################################### @@ -727,6 +780,9 @@ , T5(T5, t5) , T6((<|>)) , (+) + , (:.) + , (:.)(..) + , (:.)(T7, (:.), t7) ) #test hiding @@ -734,6 +790,21 @@ import Test as T hiding ( ) +#test import-hiding-many +import Prelude as X + hiding ( head + , init + , last + , maximum + , minimum + , pred + , read + , readFile + , succ + , tail + , undefined + ) + #test long-module-name-simple import TestJustShortEnoughModuleNameLikeThisOne ( ) import TestJustAbitToLongModuleNameLikeThisOneIs @@ -887,3 +958,280 @@ -- Test import Test ( test ) + + +############################################################################### +############################################################################### +############################################################################### +#group type synonyms +############################################################################### +############################################################################### +############################################################################### + +#test simple-synonym + +type MySynonym = String + +#test parameterised-synonym + +type MySynonym a = [a] + +#test long-function-synonym + +-- | Important comment thrown in +type MySynonym b a + = MySynonym a b -> MySynonym a b -> MyParamType a b -> MyParamType a b + +#test overflowing-function-synonym + +type MySynonym3 b a + = MySynonym a b + -> MySynonym a b + -- ^ RandomComment + -> MyParamType a b + -> MyParamType a b + -> MySynonym2 b a + +#test synonym-with-kind-sig + +type MySynonym (a :: * -> *) + = MySynonym a b + -> MySynonym a b + -> MyParamType a b + -> MyParamType a b + -> MySynonym2 b a + +#test synonym-with-constraint + +type MySynonym a = Num a => a -> Int + +#test synonym-overflowing-with-constraint + +type MySynonym a + = Num a + => AReallyLongTypeName + -> AnotherReallyLongTypeName + -> AThirdTypeNameToOverflow + +#test synonym-forall + +{-# LANGUAGE RankNTypes #-} + +type MySynonym = forall a . [a] + +#test synonym-operator + +type (:+:) a b = (a, b) + +#test synonym-infix + +type a `MySynonym` b = a -> b + +#test synonym-infix-operator + +type a :+: b = (a, b) + +#test synonym-infix-parens + +type (a `Foo` b) c = (a, b, c) + +#test synonym-comments + +type Foo a -- fancy type comment + = -- strange comment + Int + +#test synonym-type-operators +#pending + +type (a :+: b) = (a, b) + +#test synonym-multi-parens +#pending + +type ((a :+: b) c) = (a, c) + + +############################################################################### +############################################################################### +############################################################################### +#group class.instance +############################################################################### +############################################################################### +############################################################################### + +#test simple-instance + +instance MyClass Int where + myMethod x = x + 1 + +#test simple-method-signature + +instance MyClass Int where + myMethod :: Int -> Int + myMethod x = x + 1 + +#test simple-long-method-signature + +instance MyClass Int where + myMethod + :: Int + -> Int + -> AReallyLongType + -> AReallyLongType + -> AReallyLongType + -> Int + myMethod x = x + 1 + +#test simple-two-methods + +instance MyClass Int where + myMethod x = x + 1 + myMethod2 x = x + 1 + +#test simple-two-signatures + +instance MyClass Int where + myMethod + :: Int + -> Int + -> AReallyLongType + -> AReallyLongType + -> AReallyLongType + -> Int + myMethod x = x + 1 + + myMethod2 :: Int -> Int + myMethod2 x = x + 1 + +#test simple-instance-comment + +-- | This instance should be commented on +instance MyClass Int where + + -- | This method is also comment-worthy + myMethod x = x + 1 + +#test instance-with-type-family + +instance MyClass Int where + type MyType = Int + + myMethod :: MyType -> Int + myMethod x = x + 1 + +#test instance-with-type-family-below-method + +instance MyClass Int where + + type MyType = String + + myMethod :: MyType -> Int + myMethod x = x + 1 + + type MyType = Int + +#test instance-with-data-family + +instance MyClass Int where + + -- | This data is very important + data MyData = IntData + { intData :: String + , intData2 :: Int + } + + myMethod :: MyData -> Int + myMethod = intData2 + +#test instance-with-data-family-below-method + +instance MyClass Int where + -- | This data is important + data MyData = Test Int Int + + myMethod :: MyData -> Int + myMethod = intData2 + + -- | This data is also important + data MyData2 = IntData + { intData :: String + -- ^ Interesting field + , intData2 :: Int + } + + +############################################################################### +############################################################################### +############################################################################### +#group whitespace-newlines +############################################################################### +############################################################################### +############################################################################### + +#test module-import-newlines + +module Main where + +import Prelude + +firstDecl = True + +#test function-where-newlines + +func = do + + -- complex first step + aaa + + -- complex second step + bbb + + where + + helper :: Helper + helper = helpful + + other :: Other + other = True + + +############################################################################### +############################################################################### +############################################################################### +#group typefam.instance +############################################################################### +############################################################################### +############################################################################### + +#test simple-typefam-instance + +type instance MyFam Bool = String + +#test simple-typefam-instance-param-type + +type instance MyFam (Maybe a) = a -> Bool + +#test simple-typefam-instance-parens + +type instance (MyFam (String -> Int)) = String + +#test simple-typefam-instance-overflow + +type instance MyFam ALongishType + = AMuchLongerTypeThanThat + -> AnEvenLongerTypeThanTheLastOne + -> ShouldDefinitelyOverflow + +#test simple-typefam-instance-comments + +-- | A happy family +type instance MyFam Bool -- This is an odd one + = AnotherType -- Here's another + +#test simple-typefam-instance-parens-comment + +-- | A happy family +type instance (MyFam Bool) -- This is an odd one + = -- Here's another + AnotherType diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -66,3 +66,67 @@ b <- g a return (a, b) +############################################################################### +## ExplicitNamespaces + PatternSynonyms +#test explicitnamespaces_patternsynonyms export +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE PatternSynonyms #-} +module Test (type (++), (++), pattern Foo) where + +#test explicitnamespaces_patternsynonyms import +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE PatternSynonyms #-} +import Test ( type (++) + , (++) + , pattern Foo + , pattern (:.) + ) + +############################################################################### +## UnboxedTuples + MagicHash +#test unboxed-tuple and vanilla names +{-# LANGUAGE UnboxedTuples #-} +spanKey :: (# Int, Int #) -> (# Int, Int #) +spanKey = case foo of + (# bar, baz #) -> (# baz, bar #) + +#test unboxed-tuple and hashed name +{-# LANGUAGE MagicHash, UnboxedTuples #-} +spanKey :: (# Int#, Int# #) -> (# Int#, Int# #) +spanKey = case foo of + (# bar#, baz# #) -> (# baz# +# bar#, bar# #) + + +############################################################################### +## QuasiQuotes +#test quasi-quotes simple 1 +{-# LANGUAGE QuasiQuotes #-} +func = [blub| + asd + qwe + |] + +#test quasi-quotes simple 2 +{-# LANGUAGE QuasiQuotes #-} +func = [blub| + asd + qwe|] + +#test quasi-quotes ignoring layouting +{-# LANGUAGE QuasiQuotes #-} +func = do + let body = [json| + hello + |] + pure True + +#test quasi-quotes ignoring layouting, strict mode +-- brittany { lconfig_allowHangingQuasiQuotes: False } +{-# LANGUAGE QuasiQuotes #-} +func = do + let + body = + [json| + hello + |] + pure True diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -43,7 +43,7 @@ } #test record construction 1 -func = Foo {_lstate_indent = _lstate_indent state} +func = Foo { _lstate_indent = _lstate_indent state } #test record construction 2 func = Foo @@ -53,10 +53,9 @@ #test record construction 3 func = do - Foo - { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } + Foo { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + } #test post-indent comment func = do @@ -478,17 +477,17 @@ #test issue 52 a {-# LANGUAGE RecordWildCards #-} -v = A {a = 1, ..} where b = 2 +v = A { a = 1, .. } where b = 2 #test issue 52 b {-# LANGUAGE RecordWildCards #-} -v = A {..} where b = 2 +v = A { .. } where b = 2 #test issue 52 c {-# LANGUAGE RecordWildCards #-} -v = A {a = 1, b = 2, c = 3} +v = A { a = 1, b = 2, c = 3 } #test issue 63 a #pending fix does not work on 8.0.2 @@ -608,6 +607,64 @@ go _ ((_, IRTypeError ps t1 t2) : _) = Left $ makeError ps t1 t2 #test issue 89 - type-family-instance - type instance (XPure StageParse) = () type Pair a = (a, a) + +#test issue 144 +-- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } +dsfnjKeekbwwbosbOfakxqRsiyix cnehokzozwbVaguvu migbnaRwutbz = + let + eyuAfrarIso' + :: (RveoexdxunuAafalm -> Axlau (Axlau (a, OinejrdCplle))) + -> Gbodoy + -> Axlau (Axlau OinejrdCplle, Gbodoy) + eyuAfrarIso' = ulcPaaekBst cnehokzozwbVaguvu + amkgoxEhalazJjxunecCuIfaw + :: Axlau (Axlau OinejrdCplle, Gbodoy) -> Axlau RqlnrluYqednbCiggxi + amkgoxEhalazJjxunecCuIfaw uKqviuBisjtn = do + (sEmo, quc) <- uKqviuBisjtn + pure (xoheccewfWoeyiagOkfodiq sEmo quc) + xoheccewfWoeyiagOkfodiq + :: Axlau OinejrdCplle -> Gbodoy -> RqlnrluYqednbCiggxi + xoheccewfWoeyiagOkfodiq sEmo quc = case migbnaRwutbz of + Afogmf -> xgeqe (OfBkkuih quc) (Ciitog quc) sEmo + in QabqyilexuiNizzhsQuxxac migbnaRwutbz (hwaTihhjt lhowvscIiozgqe) + +#test issue 159 +spec = do + it "creates a snapshot at the given level" . withGraph runDB $ do + lift $ do + studentDiagnosticReadingLevel updatedStudent `shouldBe` Just 10 -- x + elaSnapshotReadingLevel snapshot `shouldBe` 12 + +#test non-bottom-specialcase-altsearch +jaicyhHumzo btrKpeyiFej mava = do + m :: VtohxeRgpmgsu <- qloxIfiq mava + case m of + ZumnaoFujayerIswadabo kkecm chlixxag -> do + imomue <- ozisduRaqiseSBAob btrKpeyiFej $ \s -> + case MizA.pigevo kkecm (_tc_gulawulu s) of + Ebocaba -> + ( s { _tc_gulawulu = MizA.jxariu kkecm rwuRqxzhjo (_tc_gulawulu s) } + , Gtzvonm + ) + Xcde{} -> (s, Pioemav) + pure imomue + +#test issue 214 +-- brittany { lconfig_indentPolicy: IndentPolicyMultiple } +foo = bar + arg1 -- this is the first argument + arg2 -- this is the second argument + arg3 -- this is the third argument, now I'll skip one comment + arg4 + arg5 -- this is the fifth argument + arg6 -- this is the sixth argument + +#test issue 234 + +True `nand` True = False +nand _ _ = True + +nor False False = True +_ `nor` _ = False diff --git a/src-literatetests/30-tests-context-free.blt b/src-literatetests/30-tests-context-free.blt --- a/src-literatetests/30-tests-context-free.blt +++ b/src-literatetests/30-tests-context-free.blt @@ -736,6 +736,22 @@ import Test hiding () import Test as T hiding () +#test import-hiding-many +import Prelude as X + hiding + ( head + , init + , last + , maximum + , minimum + , pred + , read + , readFile + , succ + , tail + , undefined + ) + #test long-module-name-simple import TestJustShortEnoughModuleNameLikeThisOne () import TestJustAbitToLongModuleNameLikeThisOneIs () @@ -931,7 +947,7 @@ } #test record construction 1 -func = Foo {_lstate_indent = _lstate_indent state} +func = Foo { _lstate_indent = _lstate_indent state } #test record construction 2 func = Foo @@ -1361,6 +1377,22 @@ a = b @1 cccc = () in foo + +#test issue 176 + +record :: Record +record = Record + { rProperties = + [ "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + ] + } ############################################################################### diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -1,12 +1,13 @@ {-# LANGUAGE QuasiQuotes #-} -module Main where +module Main (main) where #include "prelude.inc" import Test.Hspec +import Test.Hspec.Runner ( hspecWith, defaultConfig, configConcurrentJobs ) import NeatInterpolation @@ -177,6 +178,7 @@ , _lconfig_hangingTypeSignature = coerce False , _lconfig_reformatModulePreamble = coerce True , _lconfig_allowSingleLineExportList = coerce True + , _lconfig_allowHangingQuasiQuotes = coerce True } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -59,6 +59,7 @@ , _lconfig_hangingTypeSignature = coerce False , _lconfig_reformatModulePreamble = coerce True , _lconfig_allowSingleLineExportList = coerce True + , _lconfig_allowHangingQuasiQuotes = coerce True } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -17,8 +17,9 @@ #include "prelude.inc" -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import Data.Data @@ -27,9 +28,9 @@ import qualified Data.Yaml import qualified Data.ByteString.Char8 import Data.CZipWith -import qualified UI.Butcher.Monadic as Butcher +import qualified UI.Butcher.Monadic as Butcher -import qualified Data.Text.Lazy.Builder as Text.Builder +import qualified Data.Text.Lazy.Builder as Text.Builder import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Config.Types @@ -50,15 +51,19 @@ import Language.Haskell.Brittany.Internal.Transformations.Columns import Language.Haskell.Brittany.Internal.Transformations.Indent -import qualified GHC as GHC hiding (parseModule) -import ApiAnnotation ( AnnKeywordId(..) ) -import GHC ( runGhc, GenLocated(L), moduleNameString ) -import SrcLoc ( SrcSpan ) +import qualified GHC as GHC + hiding ( parseModule ) +import ApiAnnotation ( AnnKeywordId(..) ) +import GHC ( runGhc + , GenLocated(L) + , moduleNameString + ) +import SrcLoc ( SrcSpan ) import HsSyn -import qualified DynFlags as GHC -import qualified GHC.LanguageExtensions.Type as GHC +import qualified DynFlags as GHC +import qualified GHC.LanguageExtensions.Type as GHC -import Data.Char (isSpace) +import Data.Char ( isSpace ) @@ -71,7 +76,7 @@ extractCommentConfigs :: ExactPrint.Anns -> TopLevelDeclNameMap - -> Either (String, String) InlineConfig + -> Either (String, String) (CConfig Option, PerItemConfig) extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do let commentLiness = @@ -117,7 +122,8 @@ , \s -> "{" `isPrefixOf` dropWhile (== ' ') s , Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document") $ fmap (\lconf -> (mempty { _conf_layout = lconf }, "")) - . Data.Yaml.decode + . either (\_ -> Nothing) Just + . Data.Yaml.decodeEither' . Data.ByteString.Char8.pack -- TODO: use some proper utf8 encoder instead? ) @@ -200,11 +206,10 @@ _ -> False ] - pure $ InlineConfig - { _icd_perModule = perModule - , _icd_perBinding = perBinding - , _icd_perKey = perKey - } + pure + $ ( perModule + , PerItemConfig { _icd_perBinding = perBinding, _icd_perKey = perKey } + ) getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap @@ -256,17 +261,20 @@ case parseResult of Left err -> throwE [ErrorInput err] Right x -> pure x - inlineConf <- either (throwE . (: []) . uncurry ErrorMacroConfig) pure - $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) + (inlineConf, perItemConf) <- + either (throwE . (: []) . uncurry ErrorMacroConfig) pure + $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) + let moduleConfig = cZipWith fromOptionIdentity config inlineConf (errsWarns, outputTextL) <- do let omitCheck = - config + moduleConfig & _conf_errorHandling & _econf_omit_output_valid_check & confUnpack (ews, outRaw) <- if hasCPP || omitCheck - then return $ pPrintModule config inlineConf anns parsedSource - else lift $ pPrintModuleAndCheck config inlineConf anns parsedSource + 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 @@ -284,7 +292,7 @@ customErrOrder ErrorUnknownNode{} = 3 customErrOrder ErrorMacroConfig{} = 5 let hasErrors = - case config & _conf_errorHandling & _econf_Werror & confUnpack of + 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 @@ -297,35 +305,31 @@ -- can occur. pPrintModule :: Config - -> InlineConfig + -> PerItemConfig -> ExactPrint.Anns -> GHC.ParsedSource -> ([BrittanyError], TextL.Text) pPrintModule conf inlineConf anns parsedModule = - let - ((out, errs), debugStrings) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterW - $ MultiRWSS.withMultiReader anns - $ MultiRWSS.withMultiReader conf - $ MultiRWSS.withMultiReader inlineConf - $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) - $ do - traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations - $ annsDoc anns - ppModule parsedModule - tracer = - if Seq.null debugStrings - then - id - else - trace ("---- DEBUGMESSAGES ---- ") - . foldr (seq . join trace) id debugStrings - in - tracer $ (errs, Text.Builder.toLazyText out) + let ((out, errs), debugStrings) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterW + $ MultiRWSS.withMultiReader anns + $ MultiRWSS.withMultiReader conf + $ MultiRWSS.withMultiReader inlineConf + $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) + $ do + traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations + $ annsDoc anns + ppModule parsedModule + tracer = if Seq.null debugStrings + then id + else + trace ("---- DEBUGMESSAGES ---- ") + . foldr (seq . join trace) id debugStrings + in tracer $ (errs, Text.Builder.toLazyText out) -- unless () $ do -- -- debugStrings `forM_` \s -> @@ -335,7 +339,7 @@ -- if it does not. pPrintModuleAndCheck :: Config - -> InlineConfig + -> PerItemConfig -> ExactPrint.Anns -> GHC.ParsedSource -> IO ([BrittanyError], TextL.Text) @@ -361,18 +365,20 @@ case parseResult of Left (_ , s ) -> return $ Left $ "parsing error: " ++ s Right (anns, parsedModule) -> runExceptT $ do - inlineConf <- + (inlineConf, perItemConf) <- case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of Left err -> throwE $ "error in inline config: " ++ show err Right x -> pure x + let moduleConf = cZipWith fromOptionIdentity conf inlineConf let omitCheck = conf & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack (errs, ltext) <- if omitCheck - then return $ pPrintModule conf inlineConf anns parsedModule - else lift $ pPrintModuleAndCheck conf inlineConf anns parsedModule + then return $ pPrintModule moduleConf perItemConf anns parsedModule + else lift + $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule if null errs then pure $ TextL.toStrict $ ltext else @@ -423,7 +429,8 @@ toLocal :: Config -> ExactPrint.Anns -> PPMLocal a -> PPM a toLocal conf anns m = do - (x, write) <- lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m + (x, write) <- + lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write) pure x @@ -434,8 +441,7 @@ let declAnnKey = ExactPrint.mkAnnKey decl let declBindingNames = getDeclBindingNames decl inlineConf <- mAsk - let inlineModConf = _icd_perModule inlineConf - let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf + let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf let mBindingConfs = declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf filteredAnns <- mAsk @@ -447,8 +453,8 @@ config <- mAsk - let config' = cZipWith fromOptionIdentity config $ mconcat - (inlineModConf : (catMaybes (mBindingConfs ++ [mDeclConf]))) + let config' = cZipWith fromOptionIdentity config + $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack toLocal config' filteredAnns $ do @@ -481,16 +487,24 @@ getDeclBindingNames :: LHsDecl GhcPs -> [String] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ getDeclBindingNames (L _ decl) = case decl of + SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) + ValD _ (FunBind _ (L _ n) _ _ _) -> [Text.unpack $ rdrNameToText n] + _ -> [] +#else +getDeclBindingNames (L _ decl) = case decl of SigD (TypeSig ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) ValD (FunBind (L _ n) _ _ _ _) -> [Text.unpack $ rdrNameToText n] - _ -> [] + _ -> [] +#endif -- Prints the information associated with the module annotation -- This includes the imports -ppPreamble :: GenLocated SrcSpan (HsModule GhcPs) - -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] +ppPreamble + :: GenLocated SrcSpan (HsModule GhcPs) + -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do filteredAnns <- mAsk <&> \annMap -> Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap @@ -548,8 +562,8 @@ if shouldReformatPreamble then toLocal config filteredAnns' $ withTransformedAnns lmod $ do - briDoc <- briDocMToPPM $ layoutModule lmod - layoutBriDoc briDoc + briDoc <- briDocMToPPM $ layoutModule lmod + layoutBriDoc briDoc else let emptyModule = L loc m { hsmodDecls = [] } in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule @@ -557,22 +571,33 @@ _sigHead :: Sig GhcPs -> String _sigHead = \case +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + TypeSig _ names _ -> +#else TypeSig names _ -> +#endif "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names) _ -> "unknown sig" _bindHead :: HsBind GhcPs -> String +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ _bindHead = \case + FunBind _ fId _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) + PatBind _ _pat _ ([], []) -> "PatBind smth" + _ -> "unknown bind" +#else +_bindHead = \case FunBind fId _ _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) PatBind _pat _ _ _ ([], []) -> "PatBind smth" - _ -> "unknown bind" + _ -> "unknown bind" +#endif layoutBriDoc :: BriDocNumbered -> PPMLocal () layoutBriDoc briDoc = do -- first step: transform the briDoc. - briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do + briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do -- Note that briDoc is BriDocNumbered, but state type is BriDoc. -- That's why the alt-transform looks a bit special here. traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw @@ -581,26 +606,33 @@ $ briDoc -- bridoc transformation: remove alts transformAlts briDoc >>= mSet - mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-alt" - _dconf_dump_bridoc_simpl_alt + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt -- bridoc transformation: float stuff in mGet >>= transformSimplifyFloating .> mSet - mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-floating" - _dconf_dump_bridoc_simpl_floating + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-floating" + _dconf_dump_bridoc_simpl_floating -- bridoc transformation: par removal mGet >>= transformSimplifyPar .> mSet - mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-par" - _dconf_dump_bridoc_simpl_par + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par -- bridoc transformation: float stuff in mGet >>= transformSimplifyColumns .> mSet - mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-columns" - _dconf_dump_bridoc_simpl_columns + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns -- bridoc transformation: indent mGet >>= transformSimplifyIndent .> mSet - mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-indent" - _dconf_dump_bridoc_simpl_indent - mGet >>= briDocToDoc .> traceIfDumpConf "bridoc final" - _dconf_dump_bridoc_final + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final -- -- convert to Simple type -- simpl <- mGet <&> transformToSimple -- return simpl @@ -625,6 +657,6 @@ let remainingComments = extractAllComments =<< Map.elems (_lstate_comments state') remainingComments - `forM_` (fst .> show .> ErrorUnusedComment .> (:[]) .> mTell) + `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell) return $ () diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -19,6 +19,8 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation ) +import GHC ( AnnKeywordId (..) ) + import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.BackendUtils import Language.Haskell.Brittany.Internal.Utils @@ -149,6 +151,8 @@ mSet $ state { _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state } + BDPlain t -> do + layoutWriteAppend t BDAnnotationPrior annKey bd -> do state <- mGet let m = _lstate_comments state @@ -170,9 +174,13 @@ priors `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> do - -- evil hack for CPP: case comment of ('#':_) -> layoutMoveToCommentPos y (-999) + -- ^ evil hack for CPP + "(" -> pure () + ")" -> pure () + -- ^ these two fix the formatting of parens + -- on the lhs of type alias defs _ -> layoutMoveToCommentPos y x -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline @@ -229,7 +237,10 @@ { _lstate_comments = Map.adjust ( \ann -> ann { ExactPrint.annFollowingComments = [] , ExactPrint.annPriorComments = [] - , ExactPrint.annsDP = [] + , ExactPrint.annsDP = + flip filter (ExactPrint.annsDP ann) $ \case + (ExactPrint.Types.AnnComment{}, _) -> False + _ -> True } ) annKey @@ -241,16 +252,19 @@ Just comments -> do comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> do - -- evil hack for CPP: case comment of ('#':_) -> layoutMoveToCommentPos y (-999) + -- ^ evil hack for CPP + ")" -> pure () + -- ^ fixes the formatting of parens + -- on the lhs of type alias defs _ -> layoutMoveToCommentPos y x -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline -- layoutMoveToIndentCol y layoutWriteAppendMultiline $ Text.pack $ comment -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } - BDMoveToKWDP annKey keyword bd -> do + BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do mDP <- do state <- mGet let m = _lstate_comments state @@ -260,12 +274,14 @@ , (ExactPrint.Types.G kw1, dp) <- ann , keyword == kw1 ] + -- mTell $ Seq.fromList ["KWDP: " ++ show annKey ++ " " ++ show mAnn] pure $ case relevant of [] -> Nothing (dp:_) -> Just dp case mDP of - Nothing -> pure () - Just (ExactPrint.Types.DP (y, x)) -> layoutMoveToCommentPos y x + Nothing -> pure () + Just (ExactPrint.Types.DP (y, x)) -> + layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) layoutBriDocM bd BDNonBottomSpacing bd -> layoutBriDocM bd BDSetParSpacing bd -> layoutBriDocM bd @@ -296,10 +312,11 @@ BDForceSingleline bd -> rec bd BDForwardLineMode bd -> rec bd BDExternal _ _ _ t -> return $ Text.length t + BDPlain t -> return $ Text.length t BDAnnotationPrior _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd BDLines ls@(_:_) -> do x <- StateS.get return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x @@ -315,35 +332,37 @@ where rec :: BriDoc -> Bool rec = \case - BDEmpty -> False - BDLit _ -> False - BDSeq bds -> any rec bds - BDCols _ bds -> any rec bds - BDSeparator -> False - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd - BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar _ _ _ -> True - BDAlt{} -> error "briDocIsMultiLine BDAlt" - BDForceMultiline _ -> True - BDForceSingleline bd -> rec bd - BDForwardLineMode bd -> rec bd + BDEmpty -> False + BDLit _ -> False + BDSeq bds -> any rec bds + BDCols _ bds -> any rec bds + BDSeparator -> False + BDAddBaseY _ bd -> rec bd + BDBaseYPushCur bd -> rec bd + BDBaseYPop bd -> rec bd + BDIndentLevelPushCur bd -> rec bd + BDIndentLevelPop bd -> rec bd + BDPar _ _ _ -> True + BDAlt{} -> error "briDocIsMultiLine BDAlt" + BDForceMultiline _ -> True + BDForceSingleline bd -> rec bd + BDForwardLineMode bd -> rec bd BDExternal _ _ _ t | [_] <- Text.lines t -> False - BDExternal _ _ _ _ -> True - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ bd -> rec bd - BDLines (_:_:_) -> True - BDLines [_ ] -> False - BDLines [] -> error "briDocIsMultiLine BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing bd -> rec bd - BDDebug _ bd -> rec bd + BDExternal _ _ _ _ -> True + BDPlain t | [_] <- Text.lines t -> False + BDPlain _ -> True + BDAnnotationPrior _ bd -> rec bd + BDAnnotationKW _ _ bd -> rec bd + BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd + BDLines (_ : _ : _) -> True + BDLines [_ ] -> False + BDLines [] -> error "briDocIsMultiLine BDLines []" + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing bd -> rec bd + BDDebug _ bd -> rec bd -- In theory -- ========= @@ -527,7 +546,7 @@ (BDCols ColGuardedBody _) -> True (BDCols ColBindStmt _) -> True (BDCols ColDoLet _) -> True - (BDCols ColRecUpdate _) -> False + (BDCols ColRec _) -> False (BDCols ColListComp _) -> False (BDCols ColList _) -> False (BDCols ColApp{} _) -> True diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -188,19 +188,20 @@ { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of Left i -> if y == 0 then Left i else Right y Right{} -> Right y - , _lstate_addSepSpace = if Data.Maybe.isJust (_lstate_commentCol state) - then Just $ case _lstate_curYOrAddNewline state of - Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x - Right{} -> _lstate_indLevelLinger state + x - else Just $ if y == 0 then x else _lstate_indLevelLinger state + x - , _lstate_commentCol = Just $ case _lstate_commentCol state of - Just existing -> existing - Nothing -> case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state + , _lstate_addSepSpace = + Just $ if Data.Maybe.isJust (_lstate_commentCol state) + then case _lstate_curYOrAddNewline state of + Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x + Right{} -> _lstate_indLevelLinger state + x + else if y == 0 then x else _lstate_indLevelLinger state + x + , _lstate_commentCol = + Just $ case _lstate_commentCol state of + Just existing -> existing + Nothing -> case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state } - -- | does _not_ add spaces to again reach the current base column. layoutWriteNewline :: ( MonadMultiWriter Text.Builder.Builder m @@ -416,13 +417,11 @@ (Right{}, Just j ) -> j (Right{}, Nothing) -> 0 layoutIndentLevelPushInternal y - layoutBaseYPushInternal y layoutIndentLevelPop :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () layoutIndentLevelPop = do traceLocal ("layoutIndentLevelPop") - layoutBaseYPopInternal layoutIndentLevelPopInternal -- why are comment indentations relative to the previous indentation on -- the first node of an additional indentation, and relative to the outer diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -75,6 +75,7 @@ , _lconfig_hangingTypeSignature = coerce False , _lconfig_reformatModulePreamble = coerce True , _lconfig_allowSingleLineExportList = coerce False + , _lconfig_allowHangingQuasiQuotes = coerce True } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = coerce False @@ -177,6 +178,7 @@ , _lconfig_hangingTypeSignature = mempty , _lconfig_reformatModulePreamble = mempty , _lconfig_allowSingleLineExportList = mempty + , _lconfig_allowHangingQuasiQuotes = mempty } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors @@ -231,18 +233,19 @@ readConfig :: MonadIO m => System.IO.FilePath -> MaybeT m (Maybe (CConfig Option)) readConfig path = do + -- TODO: probably should catch IOErrors and then omit the existence check. exists <- liftIO $ System.Directory.doesFileExist path if exists then do contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm. - fileConf <- case Data.Yaml.decodeEither contents of + fileConf <- case Data.Yaml.decodeEither' contents of Left e -> do liftIO $ putStrErrLn $ "error reading in brittany config from " ++ path ++ ":" - liftIO $ putStrErrLn e + liftIO $ putStrErrLn (Data.Yaml.prettyPrintParseException e) mzero Right x -> return x return $ Just fileConf diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -109,6 +109,24 @@ -- > , def -- > ) -- > where + , _lconfig_allowHangingQuasiQuotes :: f (Last Bool) + -- if false, the layouter sees any splices as infinitely big and places + -- them accordingly (in newlines, most likely); This also influences + -- parent nodes. + -- if true, the layouter is free to start a quasi-quotation at the end + -- of a line. + -- + -- false: + -- > let + -- > body = + -- > [json| + -- > hello + -- > |] + -- + -- true: + -- > let body = [json| + -- > hello + -- > |] } deriving (Generic) diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -70,8 +70,14 @@ parseModuleWithCpp cpp opts args fp dynCheck = ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do dflags0 <- lift $ GHC.getSessionDynFlags - (dflags1, leftover, warnings) <- lift - $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args) + (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine + dflags0 + (GHC.noLoc <$> ("-hide-all-packages" : args)) + -- that we pass -hide-all-packages here is a duplication, because + -- ExactPrint.initDynFlags also does it, but necessary because of + -- stupid and careless GHC API design. We explicitly want to pass + -- our args before calling that, so this is what we do. Should be + -- harmless. See commit 1b7576dcd1823e1c685a44927b1fcaade1319063. void $ lift $ GHC.setSessionDynFlags dflags1 dflags2 <- lift $ ExactPrint.initDynFlags fp when (not $ null leftover) @@ -191,9 +197,17 @@ genF = (\_ -> return ()) `SYB.extQ` exprF exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform () exprF lexpr@(L _ expr) = case expr of - RecordCon _lname _ _ (HsRecFields fs@(_:_) Nothing) -> +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + RecordCon _ _ (HsRecFields fs@(_:_) Nothing) -> +#else + RecordCon _ _ _ (HsRecFields fs@(_:_) Nothing) -> +#endif moveTrailingComments lexpr (List.last fs) - RecordUpd _lname fs@(_:_) _ _ _ _ -> +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + RecordUpd _ _e fs@(_:_) -> +#else + RecordUpd _e fs@(_:_) _cons _ _ _ -> +#endif moveTrailingComments lexpr (List.last fs) _ -> return () @@ -274,13 +288,13 @@ => ast -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a -withTransformedAnns ast m = do - -- TODO: implement `local` for MultiReader/MultiRWS - readers@(conf :+: anns :+: HNil) <- MultiRWSS.mGetRawR - MultiRWSS.mPutRawR (conf :+: f anns :+: HNil) - x <- m - MultiRWSS.mPutRawR readers - pure x +withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case + readers@(conf :+: anns :+: HNil) -> do + -- TODO: implement `local` for MultiReader/MultiRWS + MultiRWSS.mPutRawR (conf :+: f anns :+: HNil) + x <- m + MultiRWSS.mPutRawR readers + pure x where f anns = let ((), (annsBalanced, _), _) = diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -9,6 +9,7 @@ , lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick , askIndent , extractAllComments + , extractRestComments , filterAnns , docEmpty , docLit @@ -50,13 +51,23 @@ , appSep , docCommaSep , docParenLSep + , docParenL , docParenR + , docParenHashLSep + , docParenHashRSep + , docBracketL + , docBracketR , docTick , spacifyDocs , briDocMToPPM , allocateNode , docSharedWrapper , hasAnyCommentsBelow + , hasAnyCommentsConnected + , hasAnyCommentsPrior + , hasAnyRegularCommentsConnected + , hasAnyRegularCommentsRest + , hasAnnKeywordComment , hasAnnKeyword ) where @@ -255,9 +266,13 @@ extractAllComments :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] extractAllComments ann = - ExactPrint.annPriorComments ann - ++ ExactPrint.annFollowingComments ann - ++ ( ExactPrint.annsDP ann >>= \case + ExactPrint.annPriorComments ann ++ extractRestComments ann + +extractRestComments + :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] +extractRestComments ann = + ExactPrint.annFollowingComments ann + ++ (ExactPrint.annsDP ann >>= \case (ExactPrint.AnnComment com, dp) -> [(com, dp)] _ -> [] ) @@ -266,28 +281,80 @@ filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) +-- | True if there are any comments that are +-- a) connected to any node below (in AST sense) the given node AND +-- b) after (in source code order) the node. hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyCommentsBelow ast@(L l _) = do +hasAnyCommentsBelow ast@(L l _) = + List.any (\(c, _) -> ExactPrint.commentIdentifier c > l) + <$> astConnectedComments ast + +-- | 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 +hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast + +-- | True if there are any regular comments connected to any node below (in AST +-- sense) the given node +hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyRegularCommentsConnected ast = + any isRegularComment <$> astConnectedComments ast + +-- | Regular comments are comments that are actually "source code comments", +-- i.e. things that start with "--" or "{-". In contrast to comment-annotations +-- used by ghc-exactprint for capturing symbols (and their exact positioning). +-- +-- Only the type instance layouter makes use of this filter currently, but +-- it might make sense to apply it more aggressively or make it the default - +-- I believe that most of the time we branch on the existence of comments, we +-- only care about "regular" comments. We simply did not need the distinction +-- because "irregular" comments are not that common outside of type/data decls. +isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool +isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst + +astConnectedComments + :: Data ast + => GHC.Located ast + -> ToBriDocM [(ExactPrint.Types.Comment, ExactPrint.Types.DeltaPos)] +astConnectedComments ast = do anns <- filterAnns ast <$> mAsk - return - $ List.any (\(c, _) -> ExactPrint.commentIdentifier c > l) - $ (=<<) extractAllComments - $ Map.elems - $ anns + pure $ extractAllComments =<< Map.elems anns +hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyCommentsPrior ast = astAnn ast <&> \case + Nothing -> False + Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors + +hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyRegularCommentsRest ast = astAnn ast <&> \case + Nothing -> False + Just ann -> any isRegularComment (extractRestComments ann) + +hasAnnKeywordComment + :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool +hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case + Nothing -> False + Just ann -> any hasK (extractAllComments ann) + where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst + hasAnnKeyword :: (Data a, MonadMultiReader (Map AnnKey Annotation) m) => Located a -> AnnKeywordId -> m Bool -hasAnnKeyword ast annKeyword = do - anns <- mAsk - let hasK (ExactPrint.Types.G x, _) = x == annKeyword - hasK _ = False - pure $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of - Nothing -> False - Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks +hasAnnKeyword ast annKeyword = astAnn ast <&> \case + Nothing -> False + Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks + where + hasK (ExactPrint.Types.G x, _) = x == annKeyword + hasK _ = False +astAnn + :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m) + => GHC.Located ast + -> m (Maybe Annotation) +astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk + -- new BriDoc stuff allocateNode @@ -487,9 +554,11 @@ docMoveToKWDP :: AnnKey -> AnnKeywordId + -> Bool -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docMoveToKWDP annKey kw bdm = allocateNode . BDFMoveToKWDP annKey kw =<< bdm +docMoveToKWDP annKey kw shouldRestoreIndent bdm = + allocateNode . BDFMoveToKWDP annKey kw shouldRestoreIndent =<< bdm docAnnotationRest :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered @@ -514,11 +583,33 @@ docCommaSep = appSep $ docLit $ Text.pack "," docParenLSep :: ToBriDocM BriDocNumbered -docParenLSep = appSep $ docLit $ Text.pack "(" +docParenLSep = appSep docParenL +-- TODO: we don't make consistent use of these (yet). However, I think the +-- most readable approach overall might be something else: define +-- `lit = docLit . Text.pack` and `prepSep = docSeq [docSeparator, x]`. +-- I think those two would make the usage most readable. +-- lit "(" and appSep (lit "(") are understandable and short without +-- introducing a new top-level binding for all types of parentheses. +docParenL :: ToBriDocM BriDocNumbered +docParenL = docLit $ Text.pack "(" + docParenR :: ToBriDocM BriDocNumbered docParenR = docLit $ Text.pack ")" +docParenHashLSep :: ToBriDocM BriDocNumbered +docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] + +docParenHashRSep :: ToBriDocM BriDocNumbered +docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"] + +docBracketL :: ToBriDocM BriDocNumbered +docBracketL = docLit $ Text.pack "[" + +docBracketR :: ToBriDocM BriDocNumbered +docBracketR = docLit $ Text.pack "]" + + docTick :: ToBriDocM BriDocNumbered docTick = docLit $ Text.pack "'" @@ -535,10 +626,11 @@ :: Data.Data.Data ast => Located ast -> AnnKeywordId + -> Bool -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docNodeMoveToKWDP ast kw bdm = - docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw bdm +docNodeMoveToKWDP ast kw shouldRestoreIndent bdm = + docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw shouldRestoreIndent bdm class DocWrapable a where docWrapNode :: ( Data.Data.Data ast) @@ -678,7 +770,10 @@ docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd unknownNodeError - :: Data.Data.Data ast => String -> ast -> ToBriDocM BriDocNumbered + :: Data.Data.Data ast + => String + -> GenLocated GHC.SrcSpan ast + -> ToBriDocM BriDocNumbered unknownNodeError infoStr ast = do mTell [ErrorUnknownNode infoStr ast] docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -26,14 +26,24 @@ import Language.Haskell.Brittany.Internal.ExactPrintUtils import Language.Haskell.Brittany.Internal.Utils -import GHC ( runGhc, GenLocated(L), moduleNameString ) -import SrcLoc ( SrcSpan ) +import GHC ( runGhc + , GenLocated(L) + , moduleNameString + , AnnKeywordId(..) + ) +import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc ) import HsSyn +#if MIN_VERSION_ghc(8,6,0) +import HsExtension (NoExt (..)) +#endif import Name import BasicTypes ( InlinePragma(..) , Activation(..) , InlineSpec(..) , RuleMatchInfo(..) +#if MIN_VERSION_ghc(8,2,0) + , LexicalFixity(..) +#endif ) import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) @@ -42,39 +52,82 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Bag ( mapBagM ) +import Bag ( mapBagM, bagToList, emptyBag ) +import Data.Char (isUpper) layoutDecl :: ToBriDoc HsDecl +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ layoutDecl d@(L loc decl) = case decl of + SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) + ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case + Left ns -> docLines $ return <$> ns + Right n -> return n + TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) + InstD _ (TyFamInstD _ tfid) -> + withTransformedAnns d $ layoutTyFamInstDecl False (L loc tfid) + InstD _ (ClsInstD _ inst) -> + withTransformedAnns d $ layoutClsInst (L loc inst) + _ -> briDocByExactNoComment d +#else +layoutDecl d@(L loc decl) = case decl of SigD sig -> withTransformedAnns d $ layoutSig (L loc sig) ValD bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case Left ns -> docLines $ return <$> ns Right n -> return n - InstD (TyFamInstD{}) -> do - -- this is a (temporary (..)) workaround for "type instance" decls - -- that do not round-trip through exactprint properly. - let fixer s = case List.stripPrefix "type " s of - Just rest | not ("instance" `isPrefixOf` rest) -> - "type instance " ++ rest - _ -> s - str <- mAsk <&> \anns -> - intercalate "\n" $ fmap fixer $ lines' $ ExactPrint.exactPrint d anns - allocateNode $ BDFExternal (ExactPrint.mkAnnKey d) - (foldedAnnKeys d) - False - (Text.pack str) - _ -> briDocByExactNoComment d + TyClD tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) + InstD (TyFamInstD tfid) -> + withTransformedAnns d $ layoutTyFamInstDecl False (L loc tfid) + InstD (ClsInstD inst) -> withTransformedAnns d $ layoutClsInst (L loc inst) + _ -> briDocByExactNoComment d +#endif +-------------------------------------------------------------------------------- +-- Sig +-------------------------------------------------------------------------------- + layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ - TypeSig names (HsWC _ (HsIB _ typ _)) -> docWrapNode lsig $ do +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType names typ +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ + TypeSig names (HsWC _ (HsIB _ typ _)) -> layoutNamesAndType names typ #else /* ghc-8.0 */ - TypeSig names (HsIB _ (HsWC _ _ typ)) -> docWrapNode lsig $ do + TypeSig names (HsIB _ (HsWC _ _ typ)) -> layoutNamesAndType names typ #endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> +#else + InlineSig name (InlinePragma _ spec _arity phaseAct conlike) -> +#endif + docWrapNode lsig $ do + nameStr <- lrdrNameToTextAnn name + specStr <- specStringCompat lsig spec + let phaseStr = case phaseAct of + NeverActive -> "" -- not [] - for NOINLINE NeverActive is + -- in fact the default + AlwaysActive -> "" + ActiveBefore _ i -> "[~" ++ show i ++ "] " + ActiveAfter _ i -> "[" ++ show i ++ "] " + let conlikeStr = case conlike of + FunLike -> "" + ConLike -> "CONLIKE " + docLit + $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) + <> nameStr + <> Text.pack " #-}" +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType names typ +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ + ClassOpSig False names (HsIB _ typ _) -> layoutNamesAndType names typ +#else /* ghc-8.0 */ + ClassOpSig False names (HsIB _ typ) -> layoutNamesAndType names typ +#endif + _ -> briDocByExactNoComment lsig -- TODO + where + layoutNamesAndType names typ = docWrapNode lsig $ do nameStrs <- names `forM` lrdrNameToTextAnn let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs typeDoc <- docSharedWrapper layoutType typ @@ -94,42 +147,11 @@ ] ] ] - else - docAlt - $ [ docSeq - [ appSep $ docWrapNodeRest lsig $ docLit nameStr - , appSep $ docLit $ Text.pack "::" - , docForceSingleline typeDoc - ] - | not hasComments - ] - ++ [ docAddBaseY BrIndentRegular $ docPar - (docWrapNodeRest lsig $ docLit nameStr) - ( docCols - ColTyOpPrefix - [ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) $ typeDoc - ] - ) - ] - InlineSig name (InlinePragma _ spec _arity phaseAct conlike) -> - docWrapNode lsig $ do - nameStr <- lrdrNameToTextAnn name - specStr <- specStringCompat lsig spec - let phaseStr = case phaseAct of - NeverActive -> "" -- not [] - for NOINLINE NeverActive is - -- in fact the default - AlwaysActive -> "" - ActiveBefore _ i -> "[~" ++ show i ++ "] " - ActiveAfter _ i -> "[" ++ show i ++ "] " - let conlikeStr = case conlike of - FunLike -> "" - ConLike -> "CONLIKE " - docLit - $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) - <> nameStr - <> Text.pack " #-}" - _ -> briDocByExactNoComment lsig -- TODO + else layoutLhsAndType + hasComments + (appSep . docWrapNodeRest lsig $ docLit nameStr) + "::" + typeDoc specStringCompat :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String @@ -149,8 +171,16 @@ layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + BodyStmt _ body _ _ -> layoutExpr body +#else BodyStmt body _ _ _ -> layoutExpr body +#endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + BindStmt _ lPat expr _ _ -> do +#else BindStmt lPat expr _ _ _ -> do +#endif patDoc <- docSharedWrapper layoutPat lPat expDoc <- docSharedWrapper layoutExpr expr docCols ColBindStmt @@ -159,12 +189,21 @@ ] _ -> unknownNodeError "" lgstmt -- TODO + +-------------------------------------------------------------------------------- +-- HsBind +-------------------------------------------------------------------------------- + layoutBind :: ToBriDocC (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered) layoutBind lbind@(L _ bind) = case bind of +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + FunBind _ fId (MG _ lmatches@(L _ matches) _) _ [] -> do +#else FunBind fId (MG lmatches@(L _ matches) _ _ _) _ _ [] -> do +#endif idStr <- lrdrNameToTextAnn fId binderDoc <- docLit $ Text.pack "=" funcPatDocs <- @@ -173,17 +212,22 @@ $ layoutPatternBind (Just idStr) binderDoc `mapM` matches return $ Left $ funcPatDocs +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + PatBind _ pat (GRHSs _ grhss whereBinds) ([], []) -> do +#else PatBind pat (GRHSs grhss whereBinds) _ _ ([], []) -> do +#endif patDocs <- colsWrapPat =<< layoutPat pat clauseDocs <- layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds + let mWhereArg = mWhereDocs <&> \d -> (mkAnnKey lbind, d) -- TODO: is this the right AnnKey? binderDoc <- docLit $ Text.pack "=" hasComments <- hasAnyCommentsBelow lbind fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing binderDoc (Just patDocs) clauseDocs - mWhereDocs + mWhereArg hasComments _ -> Right <$> unknownNodeError "" lbind @@ -201,42 +245,75 @@ -- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering -- x@(HsValBinds (ValBindsIn{})) -> -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsValBinds _ (ValBinds _ bindlrs sigs) -> do +#else HsValBinds (ValBindsIn bindlrs sigs) -> do - let - unordered - = [ BagBind b | b <- Data.Foldable.toList bindlrs ] - ++ [ BagSig s | s <- sigs ] - ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered +#endif + let unordered = + [ BagBind b | b <- Data.Foldable.toList bindlrs ] + ++ [ BagSig s | s <- sigs ] + ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered docs <- docWrapNode lbinds $ join <$> ordered `forM` \case BagBind b -> either id return <$> layoutBind b BagSig s -> return <$> layoutSig s return $ Just $ docs +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +-- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> + HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" + XHsLocalBindsLR{} -> error "brittany internal error: XHsLocalBindsLR" +#else x@(HsValBinds (ValBindsOut _binds _lsigs)) -> -- i _think_ this case never occurs in non-processed ast - Just . (:[]) <$> unknownNodeError "HsValBinds ValBindsOut{}" x - x@(HsIPBinds _ipBinds) -> Just . (:[]) <$> unknownNodeError "HsIPBinds" x - EmptyLocalBinds -> return $ Nothing + Just . (: []) <$> unknownNodeError "HsValBinds ValBindsOut{}" + (L noSrcSpan x) +#endif + x@(HsIPBinds{}) -> + Just . (: []) <$> unknownNodeError "HsIPBinds" (L noSrcSpan x) + EmptyLocalBinds{} -> return $ Nothing -- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is -- parSpacing stuff.B layoutGrhs :: LGRHS GhcPs (LHsExpr GhcPs) -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do +#else layoutGrhs lgrhs@(L _ (GRHS guards body)) = do +#endif guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards bodyDoc <- layoutExpr body return (guardDocs, bodyDoc, body) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +layoutGrhs (L _ (XGRHS{})) = error "brittany internal error: XGRHS" +#endif layoutPatternBind :: Maybe Text -> BriDocNumbered -> LMatch GhcPs (LHsExpr GhcPs) -> ToBriDocM BriDocNumbered -layoutPatternBind mIdStr binderDoc lmatch@(L _ match) = do +layoutPatternBind funId binderDoc lmatch@(L _ match) = do let pats = m_pats match +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + let (GRHSs _ grhss whereBinds) = m_grhss match +#else let (GRHSs grhss whereBinds) = m_grhss match +#endif patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p let isInfix = isInfixMatch match + mIdStr <- case match of +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + Match _ (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId +#elif MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ + Match (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.4 */ + Match (FunRhs matchId _ _) _ _ _ -> Just <$> lrdrNameToTextAnn matchId +#else + Match (FunBindMatch matchId _) _ _ _ -> Just <$> lrdrNameToTextAnn matchId +#endif + _ -> pure Nothing let mIdStr' = fixPatternBindIdentifier match <$> mIdStr patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of (Just idStr, p1 : pr) | isInfix -> docCols @@ -254,13 +331,14 @@ $ (List.intersperse docSeparator $ docForceSingleline <$> ps) clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds - let alignmentToken = if null pats then Nothing else mIdStr + let mWhereArg = mWhereDocs <&> \d -> (mkAnnKey lmatch, d) + let alignmentToken = if null pats then Nothing else funId hasComments <- hasAnyCommentsBelow lmatch layoutPatternBindFinal alignmentToken binderDoc (Just patDoc) clauseDocs - mWhereDocs + mWhereArg hasComments #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 && ghc-8.4 */ @@ -291,7 +369,8 @@ -> BriDocNumbered -> Maybe BriDocNumbered -> [([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)] - -> Maybe [BriDocNumbered] + -> Maybe (ExactPrint.AnnKey, [BriDocNumbered]) + -- ^ AnnKey for the node that contains the AnnWhere position annotation -> Bool -> ToBriDocM BriDocNumbered layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments = do @@ -317,30 +396,36 @@ -- be shared between alternatives. wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of Nothing -> return $ [] - Just [w] -> fmap (pure . pure) $ docAlt + Just (annKeyWhere, [w]) -> fmap (pure . pure) $ docAlt [ docEnsureIndent BrIndentRegular $ docSeq [ docLit $ Text.pack "where" , docSeparator , docForceSingleline $ return w ] - , docEnsureIndent whereIndent $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent - $ docSetIndentLevel - $ docNonBottomSpacing - $ return w - ] - ] - Just ws -> fmap (pure . pure) $ docEnsureIndent whereIndent $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent - $ docSetIndentLevel - $ docNonBottomSpacing - $ docLines - $ return - <$> ws + , docMoveToKWDP annKeyWhere AnnWhere False + $ docEnsureIndent whereIndent + $ docLines + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent + $ docSetIndentLevel + $ docNonBottomSpacing + $ return w + ] ] + Just (annKeyWhere, ws) -> + fmap (pure . pure) + $ docMoveToKWDP annKeyWhere AnnWhere False + $ docEnsureIndent whereIndent + $ docLines + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent + $ docSetIndentLevel + $ docNonBottomSpacing + $ docLines + $ return + <$> ws + ] let singleLineGuardsDoc guards = appSep $ case guards of [] -> docEmpty [g] -> docSeq @@ -352,7 +437,7 @@ ) wherePart = case mWhereDocs of Nothing -> Just docEmpty - Just [w] -> Just $ docSeq + Just (_, [w]) -> Just $ docSeq [ docSeparator , appSep $ docLit $ Text.pack "where" , docSetIndentLevel $ docForceSingleline $ return w @@ -421,8 +506,8 @@ addAlternative $ docLines $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular - $ docNonBottomSpacing + , docNonBottomSpacing + $ docEnsureIndent BrIndentRegular $ docAddBaseY BrIndentRegular $ return body ] @@ -584,3 +669,319 @@ ] ] ++ wherePartMultiLine + + +-------------------------------------------------------------------------------- +-- TyClDecl +-------------------------------------------------------------------------------- + +layoutTyCl :: ToBriDoc TyClDecl +layoutTyCl ltycl@(L _loc tycl) = case tycl of +#if MIN_VERSION_ghc(8,6,0) + SynDecl _ name vars fixity typ -> do + let isInfix = case fixity of + Prefix -> False + Infix -> True +#elif MIN_VERSION_ghc(8,2,0) + SynDecl name vars fixity typ _ -> do + let isInfix = case fixity of + Prefix -> False + Infix -> True +#else + SynDecl name vars typ _ -> do + nameStr <- lrdrNameToTextAnn name + let isInfixTypeOp = case Text.uncons nameStr of + Nothing -> False + Just (c, _) -> not (c == '(' || isUpper c) + isInfix <- (isInfixTypeOp ||) <$> hasAnnKeyword name AnnBackquote +#endif + -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP + -- let parenWrapper = if hasTrailingParen + -- then appSep . docWrapNodeRest ltycl + -- else id + let wrapNodeRest = docWrapNodeRest ltycl + docWrapNodePrior ltycl + $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ + _ -> briDocByExactNoComment ltycl + +layoutSynDecl + :: Bool + -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) + -> Located (IdP GhcPs) + -> [LHsTyVarBndr GhcPs] + -> LHsType GhcPs + -> ToBriDocM BriDocNumbered +layoutSynDecl isInfix wrapNodeRest name vars typ = do + nameStr <- lrdrNameToTextAnn name + let + lhs = appSep . wrapNodeRest $ if isInfix + then do + let (a : b : rest) = vars + hasOwnParens <- hasAnnKeywordComment a AnnOpenP + -- This isn't quite right, but does give syntactically valid results + let needsParens = not $ null rest || hasOwnParens + docSeq + $ [ docLit $ Text.pack "type" + , docSeparator + ] + ++ [ docParenL | needsParens ] + ++ [ layoutTyVarBndr False a + , docSeparator + , docLit nameStr + , docSeparator + , layoutTyVarBndr False b + ] + ++ [ docParenR | needsParens ] + ++ fmap (layoutTyVarBndr True) rest + else + docSeq + $ [ docLit $ Text.pack "type" + , docSeparator + , docWrapNode name $ docLit nameStr + ] + ++ fmap (layoutTyVarBndr True) vars + sharedLhs <- docSharedWrapper id lhs + typeDoc <- docSharedWrapper layoutType typ + hasComments <- hasAnyCommentsConnected typ + layoutLhsAndType hasComments sharedLhs "=" typeDoc + +layoutTyVarBndr :: Bool -> ToBriDoc HsTyVarBndr +layoutTyVarBndr needsSep lbndr@(L _ bndr) = do + docWrapNodePrior lbndr $ case bndr of +#if MIN_VERSION_ghc(8,6,0) /* 8.6 */ + XTyVarBndr{} -> error "brittany internal error: XTyVarBndr" + UserTyVar _ name -> do +#else /* 8.0 8.2 8.4 */ + UserTyVar name -> do +#endif + nameStr <- lrdrNameToTextAnn name + docSeq $ [docSeparator | needsSep] ++ [docLit nameStr] +#if MIN_VERSION_ghc(8,6,0) /* 8.6 */ + KindedTyVar _ name kind -> do +#else /* 8.0 8.2 8.4 */ + KindedTyVar name kind -> do +#endif + nameStr <- lrdrNameToTextAnn name + docSeq + $ [ docSeparator | needsSep ] + ++ [ docLit $ Text.pack "(" + , appSep $ docLit nameStr + , appSep . docLit $ Text.pack "::" + , docForceSingleline $ layoutType kind + , docLit $ Text.pack ")" + ] + + +-------------------------------------------------------------------------------- +-- TyFamInstDecl +-------------------------------------------------------------------------------- + +layoutTyFamInstDecl :: Bool -> ToBriDoc TyFamInstDecl +layoutTyFamInstDecl inClass (L loc tfid) = do + let +#if MIN_VERSION_ghc(8,6,0) + linst = L loc (TyFamInstD NoExt tfid) + feqn@(FamEqn _ name pats _fixity typ) = hsib_body $ tfid_eqn tfid + lfeqn = L loc feqn +#elif MIN_VERSION_ghc(8,4,0) + linst = L loc (TyFamInstD tfid) + feqn@(FamEqn name pats _fixity typ) = hsib_body $ tfid_eqn tfid + lfeqn = L loc feqn +#elif MIN_VERSION_ghc(8,2,0) + linst = L loc (TyFamInstD tfid) + lfeqn@(L _ (TyFamEqn name boundPats _fixity typ)) = tfid_eqn tfid + pats = hsib_body boundPats +#else + linst = L loc (TyFamInstD tfid) + lfeqn@(L _ (TyFamEqn name boundPats typ)) = tfid_eqn tfid + pats = hsib_body boundPats +#endif + docWrapNodePrior linst $ do + nameStr <- lrdrNameToTextAnn name + needsParens <- hasAnnKeyword lfeqn AnnOpenP + let + instanceDoc = if inClass + then docLit $ Text.pack "type" + else docSeq + [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"] + lhs = + docWrapNode lfeqn + . appSep + . docWrapNodeRest linst + . docSeq + $ (appSep instanceDoc :) + $ [ docParenL | needsParens ] + ++ [appSep $ docWrapNode name $ docLit nameStr] + ++ intersperse docSeparator (layoutType <$> pats) + ++ [ docParenR | needsParens ] + hasComments <- (||) + <$> hasAnyRegularCommentsConnected lfeqn + <*> hasAnyRegularCommentsRest linst + typeDoc <- docSharedWrapper layoutType typ + layoutLhsAndType hasComments lhs "=" typeDoc + + +-------------------------------------------------------------------------------- +-- ClsInstDecl +-------------------------------------------------------------------------------- + +-- | Layout an @instance@ declaration +-- +-- Layout signatures and bindings using the corresponding layouters from the +-- top-level. Layout the instance head, type family instances, and data family +-- instances using ExactPrint. +layoutClsInst :: ToBriDoc ClsInstDecl +layoutClsInst lcid@(L _ cid) = docLines + [ layoutInstanceHead + , docEnsureIndent BrIndentRegular + $ docSortedLines + $ fmap layoutAndLocateSig (cid_sigs cid) + ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) + ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) + ++ fmap layoutAndLocateDataFamInsts (cid_datafam_insts cid) + ] + where + layoutInstanceHead :: ToBriDocM BriDocNumbered +#if MIN_VERSION_ghc(8,6,0) /* 8.6 */ + layoutInstanceHead = + briDocByExactNoComment + $ InstD NoExt + . ClsInstD NoExt + . removeChildren + <$> lcid +#else + layoutInstanceHead = + briDocByExactNoComment + $ InstD + . ClsInstD + . removeChildren + <$> lcid +#endif + + removeChildren :: ClsInstDecl p -> ClsInstDecl p + removeChildren c = c + { cid_binds = emptyBag + , cid_sigs = [] + , cid_tyfam_insts = [] + , cid_datafam_insts = [] + } + + -- | Like 'docLines', but sorts the lines based on location + docSortedLines + :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered + docSortedLines l = + allocateNode . BDFLines . fmap unLoc . List.sortOn getLoc =<< sequence l + + layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) + layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig + + layoutAndLocateBind :: ToBriDocC (HsBind GhcPs) (Located BriDocNumbered) + layoutAndLocateBind lbind@(L loc _) = + L loc <$> (joinBinds =<< layoutBind lbind) + + joinBinds + :: Either [BriDocNumbered] BriDocNumbered -> ToBriDocM BriDocNumbered + joinBinds = \case + Left ns -> docLines $ return <$> ns + Right n -> return n + + layoutAndLocateTyFamInsts + :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) + layoutAndLocateTyFamInsts ltfid@(L loc _) = + L loc <$> layoutTyFamInstDecl True ltfid + + layoutAndLocateDataFamInsts + :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered) + layoutAndLocateDataFamInsts ldfid@(L loc _) = + L loc <$> layoutDataFamInstDecl ldfid + + -- | Send to ExactPrint then remove unecessary whitespace + layoutDataFamInstDecl :: ToBriDoc DataFamInstDecl + layoutDataFamInstDecl ldfid = + fmap stripWhitespace <$> briDocByExactNoComment ldfid + + -- | ExactPrint adds indentation/newlines to @data@/@type@ declarations + stripWhitespace :: BriDocF f -> BriDocF f + stripWhitespace (BDFExternal ann anns b t) = + BDFExternal ann anns b $ stripWhitespace' t + stripWhitespace b = b + + -- | This fixes two issues of output coming from Exactprinting + -- associated (data) type decls. Firstly we place the output into docLines, + -- so one newline coming from Exactprint is superfluous, so we drop the + -- first (empty) line. The second issue is Exactprint indents the first + -- member in a strange fashion: + -- + -- input: + -- + -- > instance MyClass Int where + -- > -- | This data is very important + -- > data MyData = IntData + -- > { intData :: String + -- > , intData2 :: Int + -- > } + -- + -- output of just exactprinting the associated data type syntax node + -- + -- > + -- > -- | This data is very important + -- > data MyData = IntData + -- > { intData :: String + -- > , intData2 :: Int + -- > } + -- + -- To fix this, we strip whitespace from the start of the comments and the + -- first line of the declaration, stopping when we see "data" or "type" at + -- the start of a line. I.e., this function yields + -- + -- > -- | This data is very important + -- > data MyData = IntData + -- > { intData :: String + -- > , intData2 :: Int + -- > } + -- + -- Downside apart from being a hacky and brittle fix is that this removes + -- possible additional indentation from comments before the first member. + -- + -- But the whole thing is just a temporary measure until brittany learns + -- to layout data/type decls. + stripWhitespace' :: Text -> Text + stripWhitespace' t = + Text.intercalate (Text.pack "\n") $ go $ List.drop 1 $ Text.lines t + where + go [] = [] + go (line1 : lineR) = case Text.stripStart line1 of + st | isTypeOrData st -> st : lineR + | otherwise -> st : go lineR + isTypeOrData t' = + (Text.pack "type" `Text.isPrefixOf` t') + || (Text.pack "data" `Text.isPrefixOf` t') + + +-------------------------------------------------------------------------------- +-- Common Helpers +-------------------------------------------------------------------------------- + +layoutLhsAndType + :: Bool + -> ToBriDocM BriDocNumbered + -> String + -> 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] + -- lhs + -- :: typeA + -- -> typeB + -- lhs + -- = typeA + -- -> typeB + addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols + ColTyOpPrefix + [sepDoc, docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -15,7 +15,9 @@ import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types -import GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..), RdrName(..) ) +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types + +import GHC ( runGhc, GenLocated(L), SrcSpan, moduleNameString, AnnKeywordId(..), RdrName(..) ) import HsSyn import Name import qualified FastString @@ -37,9 +39,17 @@ .> confUnpack let allowFreeIndent = indentPolicy == IndentPolicyFree docWrapNode lexpr $ case expr of +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsVar _ vname -> do +#else HsVar vname -> do +#endif docLit =<< lrdrNameToTextAnn vname +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsUnboundVar _ var -> case var of +#else HsUnboundVar var -> case var of +#endif OutOfScope oname _ -> docLit $ Text.pack $ occNameString oname TrueExprHole oname -> docLit $ Text.pack $ occNameString oname HsRecFld{} -> do @@ -51,15 +61,35 @@ HsIPVar{} -> do -- TODO briDocByExactInlineOnly "HsOverLabel{}" lexpr - HsOverLit (OverLit olit _ _ _) -> do - allocateNode $ overLitValBriDoc olit +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsOverLit _ olit -> do +#else + HsOverLit olit -> do +#endif + allocateNode $ overLitValBriDoc $ ol_val olit +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsLit _ lit -> do +#else HsLit lit -> do +#endif allocateNode $ litBriDoc lit +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _) +#else HsLam (MG (L _ [lmatch@(L _ match)]) _ _ _) +#endif | pats <- m_pats match - , GRHSs [lgrhs] llocals <- m_grhss match - , L _ EmptyLocalBinds <- llocals - , L _ (GRHS [] body) <- lgrhs +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + , GRHSs _ [lgrhs] llocals <- m_grhss match +#else + , GRHSs [lgrhs] llocals <- m_grhss match +#endif + , L _ EmptyLocalBinds {} <- llocals +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + , L _ (GRHS _ [] body) <- lgrhs +#else + , L _ (GRHS [] body) <- lgrhs +#endif -> do patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body @@ -105,31 +135,60 @@ ] HsLam{} -> unknownNodeError "HsLam too complex" lexpr -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsLamCase _ XMatchGroup{} -> + error "brittany internal error: HsLamCase XMatchGroup" +#endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsLamCase _ (MG _ (L _ []) _) -> do +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4*/ + HsLamCase (MG (L _ []) _ _ _) -> do +#else /* ghc-8.0 */ + HsLamCase _ (MG (L _ []) _ _ _) -> do +#endif + docSetParSpacing $ docAddBaseY BrIndentRegular $ + (docLit $ Text.pack "\\case {}") +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4*/ HsLamCase (MG lmatches@(L _ matches) _ _ _) -> do -#else /* ghc-8.0 */ +#else /* ghc-8.0 */ HsLamCase _ (MG lmatches@(L _ matches) _ _ _) -> do #endif binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches + funcPatDocs <- docWrapNode lmatches + $ layoutPatternBind Nothing binderDoc `mapM` matches docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "\\case") (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsApp _ exp1@(L _ HsApp{}) exp2 -> do +#else HsApp exp1@(L _ HsApp{}) exp2 -> do +#endif let gather :: [LHsExpr GhcPs] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [LHsExpr GhcPs]) gather list = \case +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + L _ (HsApp _ l r) -> gather (r:list) l +#else L _ (HsApp l r) -> gather (r:list) l +#endif x -> (x, list) let (headE, paramEs) = gather [exp2] exp1 let colsOrSequence = case headE of +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + L _ (HsVar _ (L _ (Unqual occname))) -> +#else L _ (HsVar (L _ (Unqual occname))) -> +#endif docCols (ColApp $ Text.pack $ occNameString occname) _ -> docSeq headDoc <- docSharedWrapper layoutExpr headE paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs + hasComments <- hasAnyCommentsConnected exp2 runFilteredAlternative $ do -- foo x y - addAlternative + addAlternativeCond (not hasComments) $ colsOrSequence $ appSep (docForceSingleline headDoc) : spacifyDocs (docForceSingleline <$> paramDocs) @@ -167,7 +226,11 @@ ( docNonBottomSpacing $ docLines paramDocs ) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsApp _ exp1 exp2 -> do +#else HsApp exp1 exp2 -> do +#endif -- TODO: if expDoc1 is some literal, we may want to create a docCols here. expDoc1 <- docSharedWrapper layoutExpr exp1 expDoc2 <- docSharedWrapper layoutExpr exp2 @@ -177,10 +240,13 @@ , -- func argline1 -- arglines -- e.g. - -- func if x - -- then 1 - -- else 2 - docSetParSpacing + -- func Abc + -- { member1 = True + -- , member2 = 13 + -- } + docSetParSpacing -- this is most likely superfluous because + -- this is a sequence of a one-line and a par-space + -- anyways, so it is _always_ par-spaced. $ docAddBaseY BrIndentRegular $ docSeq [ appSep $ docForceSingleline expDoc1 @@ -202,9 +268,13 @@ expDoc1 expDoc2 ] -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsAppType XHsWildCardBndrs{} _ -> + error "brittany internal error: HsAppType XHsWildCardBndrs" + HsAppType (HsWC _ ty1) exp1 -> do +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ HsAppType exp1 (HsWC _ ty1) -> do -#else /* ghc-8.0 */ +#else /* ghc-8.0 */ HsAppType exp1 (HsWC _ _ ty1) -> do #endif t <- docSharedWrapper layoutType ty1 @@ -220,13 +290,23 @@ e (docSeq [docLit $ Text.pack "@", t ]) ] +#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.0 8.2 8.4 */ HsAppTypeOut{} -> do -- TODO briDocByExactInlineOnly "HsAppTypeOut{}" lexpr +#endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + OpApp _ expLeft@(L _ OpApp{}) expOp expRight -> do +#else OpApp expLeft@(L _ OpApp{}) expOp _ expRight -> do +#endif let gather :: [(LHsExpr GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) gather opExprList = \case +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1): opExprList) l1 +#else (L _ (OpApp l1 op1 _ r1)) -> gather ((op1, r1): opExprList) l1 +#endif final -> (final, opExprList) (leftOperand, appList) = gather [] expLeft leftOperandDoc <- docSharedWrapper layoutExpr leftOperand @@ -236,14 +316,29 @@ ] opLastDoc <- docSharedWrapper layoutExpr expOp expLastDoc <- docSharedWrapper layoutExpr expRight - hasComments <- hasAnyCommentsBelow lexpr + allowSinglelinePar <- do + hasComLeft <- hasAnyCommentsConnected expLeft + hasComOp <- hasAnyCommentsConnected expOp + pure $ not hasComLeft && not hasComOp +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ let allowPar = case (expOp, expRight) of + (L _ (HsVar _ (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + _ -> True +#else + let allowPar = case (expOp, expRight) of (L _ (HsVar (L _ (Unqual occname))), _) | occNameString occname == "$" -> True (_, L _ (HsApp _ (L _ HsVar{}))) -> False _ -> True +#endif runFilteredAlternative $ do - addAlternativeCond (not hasComments) + -- > one + two + three + -- or + -- > one + two + case x of + -- > _ -> three + addAlternativeCond allowSinglelinePar $ docSeq [ appSep $ docForceSingleline leftOperandDoc , docSeq @@ -265,6 +360,9 @@ -- $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] -- ) + -- > one + -- > + two + -- > + three addAlternative $ docPar leftOperandDoc @@ -272,15 +370,27 @@ $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] ) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + OpApp _ expLeft expOp expRight -> do +#else OpApp expLeft expOp _ expRight -> do +#endif expDocLeft <- docSharedWrapper layoutExpr expLeft expDocOp <- docSharedWrapper layoutExpr expOp expDocRight <- docSharedWrapper layoutExpr expRight +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ let allowPar = case (expOp, expRight) of + (L _ (HsVar _ (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + _ -> True +#else + let allowPar = case (expOp, expRight) of (L _ (HsVar (L _ (Unqual occname))), _) | occNameString occname == "$" -> True (_, L _ (HsApp _ (L _ HsVar{}))) -> False _ -> True +#endif runFilteredAlternative $ do -- one-line addAlternative @@ -300,7 +410,10 @@ addAlternative $ docAddBaseY BrIndentRegular $ docPar - expDocLeft + 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 $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] ) @@ -317,12 +430,20 @@ $ docPar expDocLeft (docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight]) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + NegApp _ op _ -> do +#else NegApp op _ -> do +#endif opDoc <- docSharedWrapper layoutExpr op docSeq [ docLit $ Text.pack "-" , opDoc ] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsPar _ innerExp -> do +#else HsPar innerExp -> do +#endif innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp docAlt [ docSeq @@ -338,25 +459,44 @@ , docLit $ Text.pack ")" ] ] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + SectionL _ left op -> do -- TODO: add to testsuite +#else SectionL left op -> do -- TODO: add to testsuite +#endif leftDoc <- docSharedWrapper layoutExpr left opDoc <- docSharedWrapper layoutExpr op docSeq [leftDoc, docSeparator, opDoc] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + SectionR _ op right -> do -- TODO: add to testsuite +#else SectionR op right -> do -- TODO: add to testsuite +#endif opDoc <- docSharedWrapper layoutExpr op rightDoc <- docSharedWrapper layoutExpr right docSeq [opDoc, docSeparator, rightDoc] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + ExplicitTuple _ args boxity -> do +#else ExplicitTuple args boxity -> do +#endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ let argExprs = args <&> \arg -> case arg of + (L _ (Present _ e)) -> (arg, Just e); + (L _ (Missing NoExt)) -> (arg, Nothing) + (L _ XTupArg{}) -> error "brittany internal error: XTupArg" +#else + let argExprs = args <&> \arg -> case arg of (L _ (Present e)) -> (arg, Just e); (L _ (Missing PlaceHolder)) -> (arg, Nothing) +#endif argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM hasComments <- hasAnyCommentsBelow lexpr let (openLit, closeLit) = case boxity of - Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") - Unboxed -> (docLit $ Text.pack "(#", docLit $ Text.pack "#)") + Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") + Unboxed -> (docParenHashLSep, docParenHashRSep) case splitFirstLast argDocs of FirstLastEmpty -> docSeq [ openLit @@ -391,10 +531,38 @@ lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] end = closeLit in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsCase _ _ XMatchGroup{} -> + error "brittany internal error: HsCase XMatchGroup" +#endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsCase _ cExp (MG _ (L _ []) _) -> do +#else + HsCase cExp (MG (L _ []) _ _ _) -> do +#endif + cExpDoc <- docSharedWrapper layoutExpr cExp + docAlt + [ docAddBaseY BrIndentRegular + $ docSeq + [ appSep $ docLit $ Text.pack "case" + , appSep $ docForceSingleline cExpDoc + , docLit $ Text.pack "of {}" + ] + , docPar + ( docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + (docLit $ Text.pack "of {}") + ] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do +#else HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do +#endif cExpDoc <- docSharedWrapper layoutExpr cExp binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches + funcPatDocs <- docWrapNode lmatches + $ layoutPatternBind Nothing binderDoc `mapM` matches docAlt [ docSetParSpacing $ docAddBaseY BrIndentRegular @@ -414,7 +582,11 @@ (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) ) ] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsIf _ _ ifExpr thenExpr elseExpr -> do +#else HsIf _ ifExpr thenExpr elseExpr -> do +#endif ifExprDoc <- docSharedWrapper layoutExpr ifExpr thenExprDoc <- docSharedWrapper layoutExpr thenExpr elseExprDoc <- docSharedWrapper layoutExpr elseExpr @@ -426,7 +598,7 @@ IndentPolicyFree -> BrIndentSpecial 3 -- TODO: some of the alternatives (especially last and last-but-one) -- overlap. - runFilteredAlternative $ do + docSetIndentLevel $ runFilteredAlternative $ do -- if _ then _ else _ addAlternativeCond (not hasComments) $ docSeq @@ -534,7 +706,11 @@ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "if") (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsLet _ binds exp1 -> do +#else HsLet binds exp1 -> do +#endif expDoc1 <- docSharedWrapper layoutExpr exp1 -- We jump through some ugly hoops here to ensure proper sharing. mBindDocs <- mapM (fmap (fmap return) . docWrapNodeRest lexpr . return) @@ -601,13 +777,14 @@ -- in -- fooooooooooooooooooo let noHangingBinds = - [ docAddBaseY BrIndentRegular + [ docNonBottomSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") (docSetBaseAndIndent $ docLines bindDocs) , docSeq [ docLit $ Text.pack "in " - , docAddBaseY BrIndentRegular expDoc1 + , docAddBaseY BrIndentRegular + $ docForceParSpacing expDoc1 ] ] addAlternative $ case indentPolicy of @@ -636,60 +813,65 @@ ] _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] -- docSeq [appSep $ docLit "let in", expDoc1] - HsDo DoExpr (L _ stmts) _ -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "do") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) - HsDo MDoExpr (L _ stmts) _ -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "mdo") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) - HsDo x (L _ stmts) _ | case x of { ListComp -> True - ; MonadComp -> True - ; _ -> False } -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - hasComments <- hasAnyCommentsBelow lexpr - runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - [ docNodeAnnKW lexpr Nothing - $ appSep - $ docLit - $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) - $ appSep - $ docForceSingleline - $ List.last stmtDocs - , appSep $ docLit $ Text.pack "|" - , docSeq $ List.intersperse docCommaSep - $ docForceSingleline <$> List.init stmtDocs - , docLit $ Text.pack " ]" - ] - addAlternative $ - let - start = docCols ColListComp - [ docNodeAnnKW lexpr Nothing - $ appSep $ docLit $ Text.pack "[" - , docSetBaseY - $ docNodeAnnKW lexpr (Just AnnOpenS) - $ List.last stmtDocs - ] - (s1:sM) = List.init stmtDocs - line1 = docCols ColListComp - [appSep $ docLit $ Text.pack "|", s1] - lineM = sM <&> \d -> - docCols ColListComp [docCommaSep, d] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] - HsDo{} -> do - -- TODO - unknownNodeError "HsDo{} no comp" lexpr +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsDo _ stmtCtx (L _ stmts) -> case stmtCtx of +#else + HsDo stmtCtx (L _ stmts) _ -> case stmtCtx of +#endif + DoExpr -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "do") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + MDoExpr -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "mdo") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + x | case x of { ListComp -> True + ; MonadComp -> True + ; _ -> False } -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + hasComments <- hasAnyCommentsBelow lexpr + runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + [ docNodeAnnKW lexpr Nothing + $ appSep + $ docLit + $ Text.pack "[" + , docNodeAnnKW lexpr (Just AnnOpenS) + $ appSep + $ docForceSingleline + $ List.last stmtDocs + , appSep $ docLit $ Text.pack "|" + , docSeq $ List.intersperse docCommaSep + $ docForceSingleline <$> List.init stmtDocs + , docLit $ Text.pack " ]" + ] + addAlternative $ + let + start = docCols ColListComp + [ docNodeAnnKW lexpr Nothing + $ appSep $ docLit $ Text.pack "[" + , docSetBaseY + $ docNodeAnnKW lexpr (Just AnnOpenS) + $ List.last stmtDocs + ] + (s1:sM) = List.init stmtDocs + line1 = docCols ColListComp + [appSep $ docLit $ Text.pack "|", s1] + lineM = sM <&> \d -> + docCols ColListComp [docCommaSep, d] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] + _ -> do + -- TODO + unknownNodeError "HsDo{} unknown stmtCtx" lexpr ExplicitList _ _ elems@(_:_) -> do elemDocs <- elems `forM` docSharedWrapper layoutExpr hasComments <- hasAnyCommentsBelow lexpr @@ -730,237 +912,125 @@ in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] ExplicitList _ _ [] -> docLit $ Text.pack "[]" +#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.0 8.2 8.4 */ ExplicitPArr{} -> do -- TODO briDocByExactInlineOnly "ExplicitPArr{}" lexpr - RecordCon lname _ _ (HsRecFields [] Nothing) -> do - let t = lrdrNameToText lname - docWrapNode lname $ docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) $ docLit $ t <> Text.pack "{" - , docLit $ Text.pack "}" - ] - RecordCon lname _ _ (HsRecFields fs@(_:_) Nothing) -> do - -- TODO: the layouter for RecordUpd is slightly more clever. Should - -- probably copy the approach from there. - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr fExpr - return (fieldl, lrdrNameToText lnameF, fExpDoc) - let line1 appender wrapper = - [ appender $ docLit $ Text.pack "{" - , docWrapNodePrior fd1l $ appSep $ docLit fd1n - , case fd1e of - Just x -> docSeq - [ appSep $ docLit $ Text.pack "=" - , docWrapNodeRest fd1l $ wrapper x - ] - Nothing -> docEmpty - ] - let lineR wrapper = fdr <&> \(lfield, fText, fDoc) -> - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> docWrapNode lfield $ docSeq - [ appSep $ docLit $ Text.pack "=" - , wrapper x - ] - Nothing -> docEmpty - ] - let lineN = - [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - , docLit $ Text.pack "}" - ] - docAlt - [ docSeq - $ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator] - ++ line1 id docForceSingleline - ++ join (lineR docForceSingleline) - ++ lineN - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docNodeAnnKW lexpr Nothing nameDoc) - ( docNonBottomSpacing - $ docLines - $ [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)] - ++ (docCols ColRecUpdate <$> lineR (docAddBaseY BrIndentRegular)) - ++ [docSeq lineN] - ) - ] - RecordCon lname _ _ (HsRecFields [] (Just 0)) -> do - let t = lrdrNameToText lname - docWrapNode lname $ docLit $ t <> Text.pack " {..}" - RecordCon lname _ _ (HsRecFields fs@(_:_) (Just dotdoti)) | dotdoti == length fs -> do - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr fExpr - return (fieldl, lrdrNameToText lnameF, fExpDoc) - let line1 appender wrapper = - [ appender $ docLit $ Text.pack "{" - , docWrapNodePrior fd1l $ appSep $ docLit fd1n - , case fd1e of - Just x -> docSeq - [ appSep $ docLit $ Text.pack "=" - , docWrapNodeRest fd1l $ wrapper x - ] - Nothing -> docEmpty - ] - let lineR wrapper = fdr <&> \(lfield, fText, fDoc) -> - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> docWrapNode lfield $ docSeq - [ appSep $ docLit $ Text.pack "=" - , wrapper x - ] - Nothing -> docEmpty - ] - let lineDot = - [ docCommaSep - , docLit $ Text.pack ".." - ] - let lineN = - [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - , docLit $ Text.pack "}" - ] - docAlt - [ docSeq - $ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator] - ++ line1 id docForceSingleline - ++ join (lineR docForceSingleline) - ++ lineDot - ++ lineN - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docNodeAnnKW lexpr Nothing nameDoc) - ( docNonBottomSpacing - $ docLines - $ [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)] - ++ (docCols ColRecUpdate <$> lineR (docAddBaseY BrIndentRegular)) - ++ [docSeq lineDot, docSeq lineN] - ) - ] - RecordCon{} -> - unknownNodeError "RecordCon with puns" lexpr - RecordUpd rExpr [] _ _ _ _ -> do - rExprDoc <- docSharedWrapper layoutExpr rExpr - docSeq [rExprDoc, docLit $ Text.pack "{}"] - RecordUpd rExpr fields@(_:_) _ _ _ _ -> do - rExprDoc <- docSharedWrapper layoutExpr rExpr - rFs@((rF1f, rF1n, rF1e):rFr) <- fields - `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do - rFExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr rFExpr - return $ case ambName of - Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) - Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) - runFilteredAlternative $ do - -- container { fieldA = blub, fieldB = blub } - addAlternative - $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc - , appSep $ docLit $ Text.pack "{" - , appSep $ docSeq $ List.intersperse docCommaSep - $ rFs <&> \case - (lfield, fieldStr, Just fieldDoc) -> - docWrapNode lfield $ docSeq - [ appSep $ docLit fieldStr - , appSep $ docLit $ Text.pack "=" - , docForceSingleline fieldDoc - ] - (lfield, fieldStr, Nothing) -> - docWrapNode lfield $ docLit fieldStr - , docLit $ Text.pack "}" - ] - -- hanging single-line fields - -- container { fieldA = blub - -- , fieldB = blub - -- } - addAlternativeCond (indentPolicy == IndentPolicyFree) - $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc - , docSetBaseY $ docLines $ let - line1 = docCols ColRecUpdate +#endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + RecordCon _ lname fields -> +#else + RecordCon lname _ _ fields -> +#endif + case fields of + HsRecFields fs Nothing -> do + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + rFs <- fs + `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + let FieldOcc _ lnameF = fieldOcc +#else + let FieldOcc lnameF _ = fieldOcc +#endif + rFExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr rFExpr + return $ (lfield, lrdrNameToText lnameF, rFExpDoc) + recordExpression indentPolicy lexpr nameDoc rFs + HsRecFields [] (Just 0) -> do + let t = lrdrNameToText lname + docWrapNode lname $ docLit $ t <> Text.pack " { .. }" + HsRecFields fs@(_:_) (Just dotdoti) | dotdoti == length fs -> do + -- TODO this should be consolidated into `recordExpression` + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + fieldDocs <- fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + let FieldOcc _ lnameF = fieldOcc +#else + let FieldOcc lnameF _ = fieldOcc +#endif + fExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr fExpr + return (fieldl, lrdrNameToText lnameF, fExpDoc) + let ((fd1l, fd1n, fd1e):fdr) = fieldDocs + let line1 wrapper = [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit rF1n - , case rF1e of - Just x -> docWrapNodeRest rF1f $ docSeq - [ appSep $ docLit $ Text.pack "=" - , docForceSingleline x - ] + , docWrapNodePrior fd1l $ appSep $ docLit fd1n + , case fd1e of + Just x -> docSeq + [ appSep $ docLit $ Text.pack "=" + , docWrapNodeRest fd1l $ wrapper x + ] Nothing -> docEmpty ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate + let lineR wrapper = fdr <&> \(lfield, fText, fDoc) -> [ docCommaSep , appSep $ docLit fText , case fDoc of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docForceSingleline x - ] + Just x -> docWrapNode lfield $ docSeq + [ appSep $ docLit $ Text.pack "=" + , wrapper x + ] Nothing -> docEmpty ] - lineN = docSeq + let lineDot = + [ docCommaSep + , docLit $ Text.pack ".." + ] + let lineN = [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty , docLit $ Text.pack "}" ] - in [line1] ++ lineR ++ [lineN] - ] - -- non-hanging with expressions placed to the right of the names - -- container - -- { fieldA = blub - -- , fieldB = potentially - -- multiline - -- } - addAlternative - $ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docNodeAnnKW lexpr Nothing rExprDoc) - (docNonBottomSpacing $ docLines $ let - expressionWrapper = case indentPolicy of - IndentPolicyLeft -> docForceParSpacing - IndentPolicyMultiple -> docForceParSpacing - IndentPolicyFree -> docSetBaseY - line1 = docCols ColRecUpdate - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit rF1n - , docWrapNodeRest rF1f $ case rF1e of - Just x -> docAlt - [ docSeq [ appSep $ docLit $ Text.pack "=" - , expressionWrapper x - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - ] - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield - $ docCols ColRecUpdate - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> docAlt - [ docSeq [ appSep $ docLit $ Text.pack "=" - , expressionWrapper x - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - ] - Nothing -> docEmpty - ] - lineN = docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - , docLit $ Text.pack "}" - ] - in [line1] ++ lineR ++ [lineN] - ) -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + docAlt -- TODO: make this addFilteredAlternative and a hanging layout when Free + [ docSeq + $ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator] + ++ line1 docForceSingleline + ++ join (lineR docForceSingleline) + ++ lineDot + ++ [docSeparator] + ++ lineN + , docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docNodeAnnKW lexpr Nothing nameDoc) + ( docNonBottomSpacing + $ docLines + $ [docCols ColRec $ line1 (docAddBaseY BrIndentRegular)] + ++ (docCols ColRec <$> lineR (docAddBaseY BrIndentRegular)) + ++ [docSeq lineDot, docSeq lineN] + ) + ] + _ -> unknownNodeError "RecordCon with puns" lexpr +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + RecordUpd _ rExpr fields -> do +#else + RecordUpd rExpr fields _ _ _ _ -> do +#endif + rExprDoc <- docSharedWrapper layoutExpr rExpr + rFs <- fields + `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do + rFExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr rFExpr + return $ case ambName of +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) + Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) + XAmbiguousFieldOcc{} -> + error "brittany internal error: XAmbiguousFieldOcc" +#else + Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) + Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) +#endif + recordExpression indentPolicy lexpr rExprDoc rFs +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + ExprWithTySig (HsWC _ XHsImplicitBndrs{}) _ -> + error "brittany internal error: ExprWithTySig HsWC XHsImplicitBndrs" + ExprWithTySig XHsWildCardBndrs{} _ -> + error "brittany internal error: ExprWithTySig XHsWildCardBndrs" + ExprWithTySig (HsWC _ (HsIB _ typ1)) exp1 -> do +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8,4 */ ExprWithTySig exp1 (HsWC _ (HsIB _ typ1 _)) -> do #else /* ghc-8.0 */ ExprWithTySig exp1 (HsIB _ (HsWC _ _ typ1)) -> do @@ -972,9 +1042,11 @@ , appSep $ docLit $ Text.pack "::" , typDoc ] +#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.0 8.2 8.4 */ ExprWithTySigOut{} -> do -- TODO briDocByExactInlineOnly "ExprWithTySigOut{}" lexpr +#endif ArithSeq _ Nothing info -> case info of From e1 -> do @@ -1019,9 +1091,11 @@ ] ArithSeq{} -> briDocByExactInlineOnly "ArithSeq" lexpr +#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.0 8.2 8.4 */ PArrSeq{} -> do -- TODO briDocByExactInlineOnly "PArrSeq{}" lexpr +#endif HsSCC{} -> do -- TODO briDocByExactInlineOnly "HsSCC{}" lexpr @@ -1037,6 +1111,18 @@ HsTcBracketOut{} -> do -- TODO briDocByExactInlineOnly "HsTcBracketOut{}" lexpr +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsSpliceE _ (HsQuasiQuote _ _ quoter _loc content) -> do +#else + HsSpliceE (HsQuasiQuote _ quoter _loc content) -> do +#endif + allocateNode $ BDFPlain + (Text.pack + $ "[" + ++ showOutputable quoter + ++ "|" + ++ showOutputable content + ++ "|]") HsSpliceE{} -> do -- TODO briDocByExactInlineOnly "HsSpliceE{}" lexpr @@ -1063,7 +1149,11 @@ briDocByExactInlineOnly "HsTickPragma{}" lexpr EWildPat{} -> do docLit $ Text.pack "_" +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + EAsPat _ asName asExpr -> do +#else EAsPat asName asExpr -> do +#endif docSeq [ docLit $ lrdrNameToText asName <> Text.pack "@" , layoutExpr asExpr @@ -1085,7 +1175,123 @@ -- TODO briDocByExactInlineOnly "ExplicitSum{}" lexpr #endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + XExpr{} -> error "brittany internal error: XExpr" +#endif +recordExpression + :: (Data.Data.Data lExpr, Data.Data.Data name) + => IndentPolicy + -> GenLocated SrcSpan lExpr + -> ToBriDocM BriDocNumbered + -> [(GenLocated SrcSpan name, Text, Maybe (ToBriDocM BriDocNumbered))] + -> ToBriDocM BriDocNumbered +recordExpression _ lexpr nameDoc [] = + docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"] + , docLit $ Text.pack "}" + ] +recordExpression indentPolicy lexpr nameDoc rFs@((rF1f, rF1n, rF1e):rFr) = + runFilteredAlternative $ do + -- container { fieldA = blub, fieldB = blub } + addAlternative + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline nameDoc + , appSep $ docLit $ Text.pack "{" + , appSep $ docSeq $ List.intersperse docCommaSep + $ rFs <&> \case + (lfield, fieldStr, Just fieldDoc) -> + docWrapNode lfield $ docSeq + [ appSep $ docLit fieldStr + , appSep $ docLit $ Text.pack "=" + , docForceSingleline fieldDoc + ] + (lfield, fieldStr, Nothing) -> + docWrapNode lfield $ docLit fieldStr + , docLit $ Text.pack "}" + ] + -- hanging single-line fields + -- container { fieldA = blub + -- , fieldB = blub + -- } + addAlternativeCond (indentPolicy == IndentPolicyFree) + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep nameDoc + , docSetBaseY $ docLines $ let + line1 = docCols ColRec + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit rF1n + , case rF1e of + Just x -> docWrapNodeRest rF1f $ docSeq + [ appSep $ docLit $ Text.pack "=" + , docForceSingleline x + ] + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRec + [ docCommaSep + , appSep $ docLit fText + , case fDoc of + Just x -> docSeq [ appSep $ docLit $ Text.pack "=" + , docForceSingleline x + ] + Nothing -> docEmpty + ] + lineN = docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + , docLit $ Text.pack "}" + ] + in [line1] ++ lineR ++ [lineN] + ] + -- non-hanging with expressions placed to the right of the names + -- container + -- { fieldA = blub + -- , fieldB = potentially + -- multiline + -- } + addAlternative + $ docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docNodeAnnKW lexpr Nothing nameDoc) + (docNonBottomSpacing $ docLines $ let + expressionWrapper = case indentPolicy of + IndentPolicyLeft -> docForceParSpacing + IndentPolicyMultiple -> docForceParSpacing + IndentPolicyFree -> docSetBaseY + line1 = docCols ColRec + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit rF1n + , docWrapNodeRest rF1f $ case rF1e of + Just x -> docAlt + [ docSeq [ appSep $ docLit $ Text.pack "=" + , expressionWrapper x + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + ] + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield + $ docCols ColRec + [ docCommaSep + , appSep $ docLit fText + , case fDoc of + Just x -> docAlt + [ docSeq [ appSep $ docLit $ Text.pack "=" + , expressionWrapper x + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + ] + Nothing -> docEmpty + ] + lineN = docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + , docLit $ Text.pack "}" + ] + in [line1] ++ lineR ++ [lineN] + ) #if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ litBriDoc :: HsLit GhcPs -> BriDocFInt diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -39,46 +39,85 @@ layoutIE :: ToBriDoc IE layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of - IEVar _ -> ien - IEThingAbs _ -> ien - IEThingAll _ -> docSeq [ien, docLit $ Text.pack "(..)"] - IEThingWith _ (IEWildcard _) _ _ -> docSeq [ien, docLit $ Text.pack "(..)"] - IEThingWith _ _ ns _ -> do +#if MIN_VERSION_ghc(8,6,0) + IEVar _ x -> layoutWrapped lie x +#else + IEVar x -> layoutWrapped lie x +#endif +#if MIN_VERSION_ghc(8,6,0) + IEThingAbs _ x -> layoutWrapped lie x +#else + IEThingAbs x -> layoutWrapped lie x +#endif +#if MIN_VERSION_ghc(8,6,0) + IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] +#else + IEThingAll x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] +#endif +#if MIN_VERSION_ghc(8,6,0) + IEThingWith _ x (IEWildcard _) _ _ -> +#else + IEThingWith x (IEWildcard _) _ _ -> +#endif + docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] +#if MIN_VERSION_ghc(8,6,0) + IEThingWith _ x _ ns _ -> do +#else + IEThingWith x _ ns _ -> do +#endif hasComments <- hasAnyCommentsBelow lie runFilteredAlternative $ do addAlternativeCond (not hasComments) $ docSeq - $ [ien, docLit $ Text.pack "("] + $ [layoutWrapped lie x, docLit $ Text.pack "("] ++ intersperse docCommaSep (map nameDoc ns) ++ [docParenR] - addAlternative - $ docAddBaseY BrIndentRegular - $ docPar ien (layoutItems (splitFirstLast ns)) + addAlternative $ 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 - ] - layoutItems (FirstLastSingleton n) = - docSetBaseY $ docLines - [docSeq [docParenLSep, docWrapNodeRest lie $ 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 - ] + layoutItems FirstLastEmpty = docSetBaseY $ docLines + [docSeq [docParenLSep, docWrapNodeRest lie docEmpty], docParenR] + layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines + [docSeq [docParenLSep, docWrapNodeRest lie $ 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] +#if MIN_VERSION_ghc(8,6,0) + IEModuleContents _ n -> docSeq +#else IEModuleContents n -> docSeq +#endif [ docLit $ Text.pack "module" , docSeparator , docLit . Text.pack . moduleNameString $ unLoc n ] _ -> docEmpty - where ien = docLit =<< lrdrNameToTextAnn (ieName <$> lie) + where +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2, 8.4, .. */ + layoutWrapped _ = \case + L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n + L _ (IEPattern n) -> do + name <- lrdrNameToTextAnn n + docLit $ Text.pack "pattern " <> name + L _ (IEType n) -> do + name <- lrdrNameToTextAnn n + docLit $ Text.pack "type " <> name +#else /* ghc-8.0 */ + layoutWrapped outer n = do + name <- lrdrNameToTextAnn n + hasType <- hasAnnKeyword n AnnType + hasPattern <- hasAnnKeyword outer AnnPattern + docLit $ if + | hasType -> Text.pack "type (" <> name <> Text.pack ")" + | hasPattern -> Text.pack "pattern " <> name + | otherwise -> name +#endif -- Helper function to deal with Located lists of LIEs. -- In particular this will also associate documentation diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -43,7 +43,11 @@ layoutImport :: ToBriDoc ImportDecl layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of +#if MIN_VERSION_ghc(8,6,0) + ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do +#else ImportDecl _ (L _ modName) pkg src safe q False mas mllies -> do +#endif importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack @@ -87,7 +91,13 @@ Just (_, llies) -> do hasComments <- hasAnyCommentsBelow llies if compact - then docSeq [hidDoc, layoutLLIEs True llies] + then docAlt + [ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True llies] + , let makeParIfHiding = if hiding + then docAddBaseY BrIndentRegular . docPar hidDoc + else id + in makeParIfHiding (layoutLLIEs True llies) + ] else do ieDs <- layoutAnnAndSepLLIEs llies docWrapNodeRest llies @@ -99,7 +109,7 @@ (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] - -- ..[hiding].( b ) + -- ..[hiding].( b ) [ieD] -> runFilteredAlternative $ do addAlternativeCond (not hasComments) $ docSeq @@ -112,9 +122,9 @@ addAlternative $ docPar (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) - -- ..[hiding].( b - -- , b' - -- ) + -- ..[hiding].( b + -- , b' + -- ) (ieD:ieDs') -> docPar (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -40,7 +40,7 @@ [ docNodeAnnKW lmod Nothing docEmpty -- A pseudo node that serves merely to force documentation -- before the node - , docNodeMoveToKWDP lmod AnnModule $ runFilteredAlternative $ do + , docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do addAlternativeCond allowSingleLine $ docForceSingleline $ docSeq diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -13,7 +13,7 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics -import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) +import GHC ( Located, runGhc, GenLocated(L), moduleNameString, ol_val ) import HsSyn import Name import BasicTypes @@ -37,11 +37,25 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" -- _ -> expr - VarPat n -> fmap Seq.singleton $ docLit $ lrdrNameToText n +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + VarPat _ n -> +#else /* ghc-8.0 8.2 8.4 */ + VarPat n -> +#endif + fmap Seq.singleton $ docLit $ lrdrNameToText n -- abc -> expr - LitPat lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + LitPat _ lit -> +#else /* ghc-8.0 8.2 8.4 */ + LitPat lit -> +#endif + fmap Seq.singleton $ allocateNode $ litBriDoc lit -- 0 -> expr +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + ParPat _ inner -> do +#else /* ghc-8.0 8.2 8.4 */ ParPat inner -> do +#endif -- (nestedpat) -> expr left <- docLit $ Text.pack "(" right <- docLit $ Text.pack ")" @@ -89,7 +103,12 @@ -- Abc { a = locA, b = locB, c = locC } -> expr1 -- Abc { a, b, c } -> expr2 let t = lrdrNameToText lname - fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do + fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + let FieldOcc _ lnameF = fieldOcc +#else + let FieldOcc lnameF _ = fieldOcc +#endif fExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutPat fPat @@ -118,7 +137,12 @@ ConPatIn lname (RecCon (HsRecFields fs@(_:_) (Just dotdoti))) | dotdoti == length fs -> do -- Abc { a = locA, .. } let t = lrdrNameToText lname - fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do + fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + let FieldOcc _ lnameF = fieldOcc +#else + let FieldOcc lnameF _ = fieldOcc +#endif fExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutPat fPat @@ -136,18 +160,28 @@ (fieldName, Nothing) -> [docLit fieldName, docCommaSep] , docLit $ Text.pack "..}" ] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + TuplePat _ args boxity -> do +#else TuplePat args boxity _ -> do +#endif -- (nestedpat1, nestedpat2, nestedpat3) -> expr -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr case boxity of - Boxed -> wrapPatListy args "(" ")" - Unboxed -> wrapPatListy args "(#" "#)" + Boxed -> wrapPatListy args "()" docParenL docParenR + Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + AsPat _ asName asPat -> do +#else AsPat asName asPat -> do +#endif -- bind@nestedpat -> expr wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@") -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + SigPat (HsWC _ (HsIB _ ty1)) pat1 -> do +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ SigPatIn pat1 (HsWC _ (HsIB _ ty1 _)) -> do -#else /* ghc-8.0 */ +#else /* ghc-8.0 */ SigPatIn pat1 (HsIB _ (HsWC _ _ ty1)) -> do #endif -- i :: Int -> expr @@ -169,19 +203,35 @@ , docForceSingleline tyDoc ] return $ xR Seq.|> xN' +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + ListPat _ elems -> +#else ListPat elems _ _ -> +#endif -- [] -> expr1 -- [nestedpat1, nestedpat2, nestedpat3] -> expr2 - wrapPatListy elems "[" "]" + wrapPatListy elems "[]" docBracketL docBracketR +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + BangPat _ pat1 -> do +#else BangPat pat1 -> do +#endif -- !nestedpat -> expr wrapPatPrepend pat1 (docLit $ Text.pack "!") +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + LazyPat _ pat1 -> do +#else LazyPat pat1 -> do +#endif -- ~nestedpat -> expr wrapPatPrepend pat1 (docLit $ Text.pack "~") - NPat llit@(L _ (OverLit olit _ _ _)) mNegative _ _ -> do +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + NPat _ llit@(L _ ol) mNegative _ -> do +#else + NPat llit@(L _ ol) mNegative _ _ -> do +#endif -- -13 -> expr - litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc olit + litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol negDoc <- docLit $ Text.pack "-" pure $ case mNegative of Just{} -> Seq.fromList [negDoc, litDoc] @@ -212,18 +262,18 @@ wrapPatListy :: [Located (Pat GhcPs)] -> String - -> String + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered) -wrapPatListy elems start end = do +wrapPatListy elems both start end = do elemDocs <- Seq.fromList elems `forM` (layoutPat >=> colsWrapPat) - sDoc <- docLit $ Text.pack start - eDoc <- docLit $ Text.pack end case Seq.viewl elemDocs of - Seq.EmptyL -> fmap Seq.singleton $ docLit $ Text.pack $ start ++ end + Seq.EmptyL -> fmap Seq.singleton $ docLit $ Text.pack both x1 Seq.:< rest -> do - rest' <- rest `forM` \bd -> docSeq - [ docLit $ Text.pack "," - , docSeparator - , return bd - ] - return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc + sDoc <- start + eDoc <- end + rest' <- rest `forM` \bd -> docSeq + [ docCommaSep + , return bd + ] + return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -34,9 +34,17 @@ indentAmount :: Int <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack docWrapNode lstmt $ case stmt of +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + LastStmt _ body False _ -> do +#else LastStmt body False _ -> do +#endif layoutExpr body +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + BindStmt _ lPat expr _ _ -> do +#else BindStmt lPat expr _ _ _ -> do +#endif patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat expDoc <- docSharedWrapper layoutExpr expr docAlt @@ -52,7 +60,11 @@ $ docPar (docLit $ Text.pack "<-") (expDoc) ] ] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + LetStmt _ binds -> do +#else LetStmt binds -> do +#endif let isFree = indentPolicy == IndentPolicyFree let indentFourPlus = indentAmount >= 4 layoutLocalBinds binds >>= \case @@ -97,7 +109,11 @@ $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") (docSetBaseAndIndent $ docLines $ return <$> bindDocs) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do +#else RecStmt stmts _ _ _ _ _ _ _ _ _ -> runFilteredAlternative $ do +#endif -- rec stmt1 -- stmt2 -- stmt3 @@ -113,7 +129,11 @@ addAlternative $ docAddBaseY BrIndentRegular $ docPar (docLit (Text.pack "rec")) (docLines $ layoutStmt <$> stmts) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + BodyStmt _ expr _ _ -> do +#else BodyStmt expr _ _ _ -> do +#endif expDoc <- docSharedWrapper layoutExpr expr docAddBaseY BrIndentRegular $ expDoc _ -> briDocByExactInlineOnly "some unknown statement" lstmt diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -23,6 +23,7 @@ import Name import Outputable ( ftext, showSDocUnsafe ) import BasicTypes +import qualified SrcLoc import DataTreePrint @@ -31,7 +32,17 @@ layoutType :: ToBriDoc HsType layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible" -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +#if MIN_VERSION_ghc(8,6,0) + HsTyVar _ promoted name -> do + t <- lrdrNameToTextAnn name + case promoted of + Promoted -> docSeq + [ docSeparator + , docTick + , docWrapNode name $ docLit t + ] + NotPromoted -> docWrapNode name $ docLit t +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ HsTyVar promoted name -> do t <- lrdrNameToTextAnn name case promoted of @@ -46,13 +57,25 @@ t <- lrdrNameToTextAnn name docWrapNode name $ docLit t #endif +#if MIN_VERSION_ghc(8,6,0) + HsForAllTy _ bndrs (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do +#else HsForAllTy bndrs (L _ (HsQualTy (L _ cntxts) typ2)) -> do +#endif typeDoc <- docSharedWrapper layoutType typ2 tyVarDocs <- bndrs `forM` \case +#if MIN_VERSION_ghc(8,6,0) + (L _ (UserTyVar _ name)) -> return $ (lrdrNameToText name, Nothing) + (L _ (KindedTyVar _ lrdrName kind)) -> do + d <- docSharedWrapper layoutType kind + return $ (lrdrNameToText lrdrName, Just $ d) + (L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr" +#else (L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing) (L _ (KindedTyVar lrdrName kind)) -> do d <- docSharedWrapper layoutType kind return $ (lrdrNameToText lrdrName, Just $ d) +#endif cntxtDocs <- cntxts `forM` docSharedWrapper layoutType let maybeForceML = case typ2 of (L _ HsFunTy{}) -> docForceMultiline @@ -143,13 +166,25 @@ ] ) ] +#if MIN_VERSION_ghc(8,6,0) + HsForAllTy _ bndrs typ2 -> do +#else HsForAllTy bndrs typ2 -> do +#endif typeDoc <- layoutType typ2 tyVarDocs <- bndrs `forM` \case +#if MIN_VERSION_ghc(8,6,0) + (L _ (UserTyVar _ name)) -> return $ (lrdrNameToText name, Nothing) + (L _ (KindedTyVar _ lrdrName kind)) -> do + d <- layoutType kind + return $ (lrdrNameToText lrdrName, Just $ return d) + (L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr" +#else (L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing) (L _ (KindedTyVar lrdrName kind)) -> do d <- layoutType kind return $ (lrdrNameToText lrdrName, Just $ return d) +#endif let maybeForceML = case typ2 of (L _ HsFunTy{}) -> docForceMultiline _ -> id @@ -210,7 +245,11 @@ ] ) ] +#if MIN_VERSION_ghc(8,6,0) + HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do +#else HsQualTy lcntxts@(L _ cntxts) typ1 -> do +#endif typeDoc <- docSharedWrapper layoutType typ1 cntxtDocs <- cntxts `forM` docSharedWrapper layoutType let @@ -234,7 +273,7 @@ list = List.tail cntxtDocs <&> \cntxtDoc -> docCols ColTyOpPrefix [ docCommaSep - , docAddBaseY (BrIndentSpecial 2) + , docAddBaseY (BrIndentSpecial 2) $ cntxtDoc ] in docPar open $ docLines $ list ++ [close] @@ -260,7 +299,11 @@ ] ) ] +#if MIN_VERSION_ghc(8,6,0) + HsFunTy _ typ1 typ2 -> do +#else HsFunTy typ1 typ2 -> do +#endif typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc2 <- docSharedWrapper layoutType typ2 let maybeForceML = case typ2 of @@ -284,7 +327,11 @@ ] ) ] +#if MIN_VERSION_ghc(8,6,0) + HsParTy _ typ1 -> do +#else HsParTy typ1 -> do +#endif typeDoc1 <- docSharedWrapper layoutType typ1 docAlt [ docSeq @@ -299,6 +346,35 @@ ]) (docLit $ Text.pack ")") ] +#if MIN_VERSION_ghc(8,6,0) + HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do + let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) + gather list = \case + L _ (HsAppTy _ ty1 ty2) -> gather (ty2:list) ty1 + final -> (final, list) + let (typHead, typRest) = gather [typ2] typ1 + docHead <- docSharedWrapper layoutType typHead + docRest <- docSharedWrapper layoutType `mapM` typRest + docAlt + [ docSeq + $ docForceSingleline docHead : (docRest >>= \d -> + [ docSeparator, docForceSingleline d ]) + , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) + ] + HsAppTy _ typ1 typ2 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + typeDoc2 <- docSharedWrapper layoutType typ2 + docAlt + [ docSeq + [ docForceSingleline typeDoc1 + , docSeparator + , docForceSingleline typeDoc2 + ] + , docPar + typeDoc1 + (docEnsureIndent BrIndentRegular typeDoc2) + ] +#else HsAppTy typ1 typ2 -> do typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc2 <- docSharedWrapper layoutType typ2 @@ -351,7 +427,12 @@ layoutAppType (L _ (HsAppPrefix t)) = layoutType t layoutAppType lt@(L _ (HsAppInfix t)) = docLit =<< lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick lt t +#endif +#if MIN_VERSION_ghc(8,6,0) + HsListTy _ typ1 -> do +#else HsListTy typ1 -> do +#endif typeDoc1 <- docSharedWrapper layoutType typ1 docAlt [ docSeq @@ -366,6 +447,8 @@ ]) (docLit $ Text.pack "]") ] +#if MIN_VERSION_ghc(8,6,0) +#else HsPArrTy typ1 -> do typeDoc1 <- docSharedWrapper layoutType typ1 docAlt @@ -381,43 +464,49 @@ ]) (docLit $ Text.pack ":]") ] +#endif +#if MIN_VERSION_ghc(8,6,0) + HsTupleTy _ tupleSort typs -> case tupleSort of +#else HsTupleTy tupleSort typs -> case tupleSort of +#endif HsUnboxedTuple -> unboxed HsBoxedTuple -> simple HsConstraintTuple -> simple HsBoxedOrConstraintTuple -> simple where - unboxed = if null typs then error "unboxed unit?" else unboxedL + unboxed = if null typs then error "brittany internal error: unboxed unit" + else unboxedL simple = if null typs then unitL else simpleL unitL = docLit $ Text.pack "()" simpleL = do docs <- docSharedWrapper layoutType `mapM` typs + let end = docLit $ Text.pack ")" + lines = List.tail docs <&> \d -> + docCols ColTyOpPrefix [docCommaSep, d] docAlt [ docSeq $ [docLit $ Text.pack "("] ++ List.intersperse docCommaSep (docForceSingleline <$> docs) - ++ [docLit $ Text.pack ")"] - , let - start = docCols ColTyOpPrefix [docParenLSep, head docs] - lines = List.tail docs <&> \d -> - docCols ColTyOpPrefix [docCommaSep, d] - end = docLit $ Text.pack ")" + ++ [end] + , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] in docPar - (docAddBaseY (BrIndentSpecial 2) $ start) + (docAddBaseY (BrIndentSpecial 2) $ line1) (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end]) ] unboxedL = do docs <- docSharedWrapper layoutType `mapM` typs + let start = docParenHashLSep + end = docParenHashRSep docAlt - [ docSeq $ [docLit $ Text.pack "(#"] - ++ List.intersperse docCommaSep docs - ++ [docLit $ Text.pack "#)"] + [ docSeq $ [start] + ++ List.intersperse docCommaSep docs + ++ [end] , let - start = docCols ColTyOpPrefix [docLit $ Text.pack "(#", head docs] - lines = List.tail docs <&> \d -> - docCols ColTyOpPrefix [docCommaSep, d] - end = docLit $ Text.pack "#)" + line1 = docCols ColTyOpPrefix [start, head docs] + lines = List.tail docs <&> \d -> + docCols ColTyOpPrefix [docCommaSep, d] in docPar - (docAddBaseY (BrIndentSpecial 2) start) + (docAddBaseY (BrIndentSpecial 2) line1) (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end]) ] HsOpTy{} -> -- TODO @@ -480,9 +569,11 @@ -- } -- , _layouter_ast = ltype -- } -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsIParamTy _ (L _ (HsIPName ipName)) typ1 -> do +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ HsIParamTy (L _ (HsIPName ipName)) typ1 -> do -#else /* ghc-8.0 */ +#else /* ghc-8.0 */ HsIParamTy (HsIPName ipName) typ1 -> do #endif typeDoc1 <- docSharedWrapper layoutType typ1 @@ -503,6 +594,8 @@ , docAddBaseY (BrIndentSpecial 2) typeDoc1 ]) ] +#if MIN_VERSION_ghc(8,6,0) +#else HsEqTy typ1 typ2 -> do typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc2 <- docSharedWrapper layoutType typ2 @@ -521,8 +614,13 @@ , docAddBaseY (BrIndentSpecial 2) typeDoc2 ]) ] +#endif -- TODO: test KindSig +#if MIN_VERSION_ghc(8,6,0) + HsKindSig _ typ1 kind1 -> do +#else HsKindSig typ1 kind1 -> do +#endif typeDoc1 <- docSharedWrapper layoutType typ1 kindDoc1 <- docSharedWrapper layoutType kind1 hasParens <- hasAnnKeyword ltype AnnOpenP @@ -640,7 +738,11 @@ ] HsExplicitTupleTy{} -> -- TODO briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype +#if MIN_VERSION_ghc(8,6,0) + HsTyLit _ lit -> case lit of +#else HsTyLit lit -> case lit of +#endif #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext HsNumTy NoSourceText _ -> @@ -652,11 +754,20 @@ HsNumTy srctext _ -> docLit $ Text.pack srctext HsStrTy srctext _ -> docLit $ Text.pack srctext #endif +#if !MIN_VERSION_ghc(8,6,0) HsCoreTy{} -> -- TODO briDocByExactInlineOnly "HsCoreTy{}" ltype +#endif HsWildCardTy _ -> docLit $ Text.pack "_" #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ HsSumTy{} -> -- TODO briDocByExactInlineOnly "HsSumTy{}" ltype +#endif +#if MIN_VERSION_ghc(8,6,0) + HsStarTy _ isUnicode -> do + if isUnicode + then docLit $ Text.pack "\x2605" -- Unicode star + else docLit $ Text.pack "*" + XHsType{} -> error "brittany internal error: XHsType" #endif diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -1,3 +1,8 @@ +#if !MIN_VERSION_ghc(8,4,0) /* ghc-8.0, ghc-8.2 */ +{-# LANGUAGE TypeFamilies #-} +#endif + + module Language.Haskell.Brittany.Internal.Prelude ( module E , module Language.Haskell.Brittany.Internal.Prelude @@ -400,5 +405,8 @@ #if !MIN_VERSION_ghc(8,4,0) /* ghc-8.0, ghc-8.2 */ +type family IdP p +type instance IdP GhcPs = RdrName + type GhcPs = RdrName #endif diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -203,6 +203,7 @@ AltLineModeStateForceSL{} -> p == VerticalSpacingParNone AltLineModeStateForceML{} -> p /= VerticalSpacingParNone AltLineModeStateContradiction -> False + -- TODO: use COMPLETE pragma instead? lineCheck _ = error "ghc exhaustive check is insufficient" lconf <- _conf_layout <$> mAsk #if INSERTTRACESALT @@ -287,6 +288,7 @@ mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } return $ x BDFExternal{} -> processSpacingSimple bdX $> bdX + BDFPlain{} -> processSpacingSimple bdX $> bdX BDFAnnotationPrior annKey bd -> do acp <- mGet mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } @@ -296,8 +298,8 @@ reWrap . BDFAnnotationRest annKey <$> rec bd BDFAnnotationKW annKey kw bd -> reWrap . BDFAnnotationKW annKey kw <$> rec bd - BDFMoveToKWDP annKey kw bd -> - reWrap . BDFMoveToKWDP annKey kw <$> rec bd + BDFMoveToKWDP annKey kw b bd -> + reWrap . BDFMoveToKWDP annKey kw b <$> rec bd BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. BDFLines (l:lr) -> do ind <- _acp_indent <$> mGet @@ -336,9 +338,13 @@ acp :: AltCurPos <- mGet tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp reWrap . BDFDebug s <$> rec bd - processSpacingSimple :: (MonadMultiReader - Config m, - MonadMultiState AltCurPos m, MonadMultiWriter (Seq String) m) => BriDocNumbered -> m () + processSpacingSimple + :: ( MonadMultiReader Config m + , MonadMultiState AltCurPos m + , MonadMultiWriter (Seq String) m + ) + => BriDocNumbered + -> m () processSpacingSimple bd = getSpacing bd >>= \case LineModeInvalid -> error "processSpacingSimple inv" LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do @@ -440,7 +446,11 @@ BDFPar{} -> error "BDPar with indent in getSpacing" BDFAlt [] -> error "empty BDAlt" BDFAlt (alt:_) -> rec alt - BDFForceMultiline bd -> rec bd + BDFForceMultiline bd -> do + mVs <- rec bd + return $ mVs >>= _vs_paragraph .> \case + VerticalSpacingParNone -> LineModeInvalid + _ -> mVs BDFForceSingleline bd -> do mVs <- rec bd return $ mVs >>= _vs_paragraph .> \case @@ -450,15 +460,19 @@ BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False _ -> VerticalSpacing 999 VerticalSpacingParNone False + BDFPlain txt -> return $ LineModeValid $ case Text.lines txt of + [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False + _ -> VerticalSpacing 999 VerticalSpacingParNone False BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd BDFAnnotationRest _annKey bd -> rec bd - BDFMoveToKWDP _annKey _kw bd -> rec bd + BDFMoveToKWDP _annKey _kw _b bd -> rec bd BDFLines [] -> return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False BDFLines ls@(_:_) -> do - lSps@(mVs:_) <- rec `mapM` ls + lSps <- rec `mapM` ls + let (mVs:_) = lSps -- separated into let to avoid MonadFail return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False | VerticalSpacing lsp _ _ <- mVs , lineMax <- getMaxVS $ maxVs $ lSps @@ -541,6 +555,8 @@ VerticalSpacingParNone -> 0 VerticalSpacingParAlways i -> i +data SpecialCompare = Unequal | Smaller | Bigger + getSpacings :: forall m . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) @@ -567,6 +583,34 @@ VerticalSpacingParNone -> True VerticalSpacingParSome i -> i <= colMax VerticalSpacingParAlways{} -> True + let specialCompare vs1 vs2 = + if ( (_vs_sameLine vs1 == _vs_sameLine vs2) + && (_vs_parFlag vs1 == _vs_parFlag vs2) + ) + then case (_vs_paragraph vs1, _vs_paragraph vs2) of + (VerticalSpacingParAlways i1, VerticalSpacingParAlways i2) -> + if i1 < i2 then Smaller else Bigger + (p1, p2) -> if p1 == p2 then Smaller else Unequal + else Unequal + let allowHangingQuasiQuotes = + config + & _conf_layout + & _lconfig_allowHangingQuasiQuotes + & confUnpack + let -- this is like List.nub, with one difference: if two elements + -- are unequal only in _vs_paragraph, with both ParAlways, we + -- treat them like equals and replace the first occurence with the + -- smallest member of this "equal group". + specialNub :: [VerticalSpacing] -> [VerticalSpacing] + specialNub [] = [] + specialNub (x1 : xr) = case go x1 xr of + (r, xs') -> r : specialNub xs' + where + go y1 [] = (y1, []) + go y1 (y2 : yr) = case specialCompare y1 y2 of + Unequal -> let (r, yr') = go y1 yr in (r, y2 : yr') + Smaller -> go y1 yr + Bigger -> go y2 yr let -- the standard function used to enforce a constant upper bound -- on the number of elements returned for each node. Should be -- applied whenever in a parent the combination of spacings from @@ -575,11 +619,7 @@ filterAndLimit = take limit -- prune so we always consider a constant -- amount of spacings per node of the BriDoc. - . filter hasOkColCount - -- throw out any spacings (i.e. children) that - -- already use more columns than available in - -- total. - . List.nub + . specialNub -- In the end we want to know if there is at least -- one valid spacing for any alternative. -- If there are duplicates in the list, then these @@ -601,6 +641,10 @@ -- layouts when we can than take non-optimal layouts -- just to be consistent with other cases where -- we'd choose non-optimal layouts. + . filter hasOkColCount + -- throw out any spacings (i.e. children) that + -- already use more columns than available in + -- total. . preFilterLimit result <- case brdc of -- BDWrapAnnKey _annKey bd -> rec bd @@ -686,7 +730,9 @@ BDFAlt alts -> do r <- rec `mapM` alts return $ filterAndLimit =<< r - BDFForceMultiline bd -> rec bd + BDFForceMultiline bd -> do + mVs <- filterAndLimit <$> rec bd + return $ filter ((/=VerticalSpacingParNone) . _vs_paragraph) mVs BDFForceSingleline bd -> do mVs <- filterAndLimit <$> rec bd return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs @@ -696,10 +742,23 @@ BDFExternal{} -> return $ [] -- yes, we just assume that we cannot properly layout -- this. + BDFPlain t -> return + [ case Text.lines t of + [] -> VerticalSpacing 0 VerticalSpacingParNone False + [t1 ] -> VerticalSpacing + (Text.length t1) + VerticalSpacingParNone + False + (t1 : _) -> VerticalSpacing + (Text.length t1) + (VerticalSpacingParAlways 0) + True + | allowHangingQuasiQuotes + ] BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd BDFAnnotationRest _annKey bd -> rec bd - BDFMoveToKWDP _annKey _kw bd -> rec bd + BDFMoveToKWDP _annKey _kw _b bd -> rec bd BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] BDFLines ls@(_:_) -> do -- we simply assume that lines is only used "properly", i.e. in @@ -707,7 +766,7 @@ -- paragraph". That most importantly means that Lines should never -- be inserted anywhere but at the start of the line. A -- counterexample would be anything like Seq[Lit "foo", Lines]. - lSpss <- fmap filterAndLimit <$> rec `mapM` ls + lSpss <- map filterAndLimit <$> rec `mapM` ls let worbled = fmap reverse $ sequence $ reverse @@ -745,7 +804,8 @@ return $ if null mVs then [VerticalSpacing 0 (VerticalSpacingParAlways colMax) False] else mVs <&> \vs -> vs - { _vs_paragraph = case _vs_paragraph vs of + { _vs_sameLine = min colMax (_vs_sameLine vs) + , _vs_paragraph = case _vs_paragraph vs of VerticalSpacingParNone -> VerticalSpacingParNone VerticalSpacingParAlways i -> VerticalSpacingParAlways i VerticalSpacingParSome i -> VerticalSpacingParAlways i diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs --- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -125,6 +125,7 @@ BDForceSingleline{} -> Nothing BDForwardLineMode{} -> Nothing BDExternal{} -> Nothing + BDPlain{} -> Nothing BDLines{} -> Nothing BDAnnotationPrior{} -> Nothing BDAnnotationKW{} -> Nothing diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs --- a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -128,6 +128,10 @@ Just $ BDBaseYPop (BDAddBaseY ind x) BDAddBaseY ind (BDDebug s x) -> Just $ BDDebug s (BDAddBaseY ind x) + BDAddBaseY ind (BDIndentLevelPop x) -> + Just $ BDIndentLevelPop (BDAddBaseY ind x) + BDAddBaseY ind (BDIndentLevelPushCur x) -> + Just $ BDIndentLevelPushCur (BDAddBaseY ind x) _ -> Nothing stepBO :: BriDoc -> BriDoc stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -17,7 +17,7 @@ import qualified Data.Text.Lazy.Builder as Text.Builder -import GHC ( Located, runGhc, GenLocated(L), moduleNameString, AnnKeywordId ) +import GHC ( Located, runGhc, GenLocated(L), moduleNameString, AnnKeywordId, SrcSpan ) import Language.Haskell.GHC.ExactPrint ( AnnKey, Comment ) import Language.Haskell.GHC.ExactPrint.Types ( KeywordId, Anns, DeltaPos, mkAnnKey ) @@ -28,9 +28,8 @@ -data InlineConfig = InlineConfig - { _icd_perModule :: CConfig Option - , _icd_perBinding :: Map String (CConfig Option) +data PerItemConfig = PerItemConfig + { _icd_perBinding :: Map String (CConfig Option) , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Option) } #if MIN_VERSION_ghc(8,2,0) @@ -38,7 +37,7 @@ #endif type PPM = MultiRWSS.MultiRWS - '[Map ExactPrint.AnnKey ExactPrint.Anns, InlineConfig, Config, ExactPrint.Anns] + '[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns] '[Text.Builder.Builder, [BrittanyError], Seq String] '[] @@ -135,7 +134,7 @@ -- output and second the corresponding, ill-formed input. | LayoutWarning String -- ^ some warning - | forall ast . Data.Data.Data ast => ErrorUnknownNode String ast + | forall ast . Data.Data.Data ast => ErrorUnknownNode String (GenLocated SrcSpan ast) -- ^ internal error: pretty-printing is not implemented for type of node -- in the syntax-tree | ErrorOutputCheck @@ -185,7 +184,7 @@ -- expected to have exactly two columns | ColBindStmt | ColDoLet -- the non-indented variant - | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect? + | ColRec | ColListComp | ColList | ColApp Text @@ -244,10 +243,12 @@ -- to be printed via exactprint Bool -- should print extra comment ? Text + | BDPlain !Text -- used for QuasiQuotes, content can be multi-line + -- (contrast to BDLit) | BDAnnotationPrior AnnKey BriDoc | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc | BDAnnotationRest AnnKey BriDoc - | BDMoveToKWDP AnnKey AnnKeywordId BriDoc + | BDMoveToKWDP AnnKey AnnKeywordId Bool BriDoc -- True if should respect x offset | BDLines [BriDoc] | BDEnsureIndent BrIndent BriDoc -- the following constructors are only relevant for the alt transformation @@ -290,10 +291,12 @@ -- to be printed via exactprint Bool -- should print extra comment ? Text + | BDFPlain !Text -- used for QuasiQuotes, content can be multi-line + -- (contrast to BDLit) | BDFAnnotationPrior AnnKey (f (BriDocF f)) | BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f)) | BDFAnnotationRest AnnKey (f (BriDocF f)) - | BDFMoveToKWDP AnnKey AnnKeywordId (f (BriDocF f)) + | BDFMoveToKWDP AnnKey AnnKeywordId Bool (f (BriDocF f)) -- True if should respect x offset | BDFLines [(f (BriDocF f))] | BDFEnsureIndent BrIndent (f (BriDocF f)) | BDFForceMultiline (f (BriDocF f)) @@ -324,10 +327,11 @@ 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 bd) = plate BDMoveToKWDP |- annKey |- kw |* 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 @@ -356,10 +360,11 @@ BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen BDFForwardLineMode bd -> BDForwardLineMode $ rec bd BDFExternal k ks c t -> BDExternal k ks c t + BDFPlain t -> BDPlain t BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd - BDFMoveToKWDP annKey kw bd -> BDMoveToKWDP annKey kw $ rec bd + 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 @@ -378,32 +383,33 @@ -- this might not work. is not used anywhere either. briDocSeqSpine :: BriDoc -> () briDocSeqSpine = \case - BDEmpty -> () - BDLit _t -> () - BDSeq list -> foldl' ((briDocSeqSpine.) . seq) () list - BDCols _sig list -> foldl' ((briDocSeqSpine.) . seq) () list - BDSeparator -> () - BDAddBaseY _ind bd -> briDocSeqSpine bd - BDBaseYPushCur bd -> briDocSeqSpine bd - BDBaseYPop bd -> briDocSeqSpine bd - BDIndentLevelPushCur bd -> briDocSeqSpine bd - BDIndentLevelPop bd -> briDocSeqSpine bd + BDEmpty -> () + BDLit _t -> () + BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list + BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list + BDSeparator -> () + BDAddBaseY _ind bd -> briDocSeqSpine bd + BDBaseYPushCur bd -> briDocSeqSpine bd + BDBaseYPop bd -> briDocSeqSpine bd + BDIndentLevelPushCur bd -> briDocSeqSpine bd + BDIndentLevelPop bd -> briDocSeqSpine bd BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented - BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts - BDForwardLineMode bd -> briDocSeqSpine bd - BDExternal{} -> () - BDAnnotationPrior _annKey bd -> briDocSeqSpine bd - BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd - BDAnnotationRest _annKey bd -> briDocSeqSpine bd - BDMoveToKWDP _annKey _kw 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 - BDDebug _s bd -> briDocSeqSpine bd + BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts + BDForwardLineMode bd -> briDocSeqSpine bd + BDExternal{} -> () + BDPlain{} -> () + BDAnnotationPrior _annKey bd -> briDocSeqSpine bd + BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd + BDAnnotationRest _annKey bd -> briDocSeqSpine bd + 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 + BDDebug _s bd -> briDocSeqSpine bd briDocForceSpine :: BriDoc -> BriDoc briDocForceSpine bd = briDocSeqSpine bd `seq` bd @@ -411,7 +417,7 @@ data VerticalSpacingPar = VerticalSpacingParNone -- no indented lines - | VerticalSpacingParSome Int -- indented lines, requiring this much + | VerticalSpacingParSome Int -- indented lines, requiring this much -- vertical space at most | VerticalSpacingParAlways Int -- indented lines, requiring this much -- vertical space at most, but should diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -24,6 +24,7 @@ , FirstLastView(..) , splitFirstLast , lines' + , showOutputable ) where @@ -69,8 +70,8 @@ showSDoc_ :: GHC.SDoc -> String showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags -showGhc :: (GHC.Outputable a) => a -> String -showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags +showOutputable :: (GHC.Outputable a) => a -> String +showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags fromMaybeIdentity :: Identity a -> Maybe a -> Identity a fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y @@ -124,7 +125,7 @@ srcSpan :: GHC.SrcSpan -> NodeLayouter srcSpan ss = simpleLayouter -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}" - $ "{" ++ showGhc ss ++ "}" + $ "{" ++ showOutputable ss ++ "}" located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a where