ormolu 0.3.1.0 → 0.4.0.0
raw patch · 72 files changed
+1263/−1158 lines, 72 filesdep +arraydep ~Cabaldep ~basedep ~ghc-lib-parser
Dependencies added: array
Dependency ranges changed: Cabal, base, ghc-lib-parser, text
Files
- CHANGELOG.md +39/−0
- CONTRIBUTING.md +3/−0
- README.md +16/−0
- app/Main.hs +53/−10
- data/examples/declaration/rewrite-rule/never-active-out.hs +1/−0
- data/examples/declaration/rewrite-rule/never-active.hs +1/−0
- data/examples/declaration/type/promotion-1-out.hs +2/−0
- data/examples/declaration/type/promotion-1.hs +2/−0
- data/examples/declaration/value/function/arrow/proc-do-complex-out.hs +2/−1
- data/examples/declaration/value/function/arrow/proc-lambdas-out.hs +2/−1
- data/examples/declaration/value/function/case-multi-line-guards-out.hs +2/−2
- data/examples/declaration/value/function/multi-way-if-out.hs +1/−1
- data/examples/declaration/value/function/multiple-guards-out.hs +4/−4
- data/examples/declaration/value/function/operators-2-out.hs +1/−1
- data/examples/declaration/value/function/pattern/multiline-guard-statement-out.hs +2/−2
- data/examples/declaration/value/function/pattern/multiple-guard-statements-out.hs +2/−2
- data/examples/declaration/value/function/record/dot-multiline-out.hs +0/−15
- data/examples/declaration/value/function/record/dot-multiline.hs +0/−10
- data/examples/declaration/value/function/record/dot-singleline-out.hs +0/−15
- data/examples/declaration/value/function/record/dot-singleline.hs +0/−14
- data/examples/declaration/value/function/record/record-dot-out.hs +16/−0
- data/examples/declaration/value/function/record/record-dot.hs +16/−0
- data/examples/module-header/empty-haddock-out.hs +1/−0
- data/examples/module-header/empty-haddock.hs +3/−0
- data/examples/other/comment-spacing-out.hs +7/−0
- data/examples/other/comment-spacing.hs +7/−0
- data/examples/other/empty-haddock-out.hs +6/−4
- data/examples/other/empty-haddock.hs +9/−4
- data/examples/other/no-linear-arrows-out.hs +0/−5
- data/examples/other/no-linear-arrows.hs +0/−4
- ormolu.cabal +8/−11
- src/GHC/DynFlags.hs +7/−8
- src/Ormolu.hs +28/−2
- src/Ormolu/Config.hs +15/−1
- src/Ormolu/Diff/ParseResult.hs +40/−24
- src/Ormolu/Imports.hs +33/−32
- src/Ormolu/Parser.hs +61/−18
- src/Ormolu/Parser/Anns.hs +0/−42
- src/Ormolu/Parser/CommentStream.hs +44/−30
- src/Ormolu/Parser/Pragma.hs +3/−5
- src/Ormolu/Parser/Result.hs +4/−6
- src/Ormolu/Printer.hs +5/−6
- src/Ormolu/Printer/Combinators.hs +13/−38
- src/Ormolu/Printer/Internal.hs +13/−31
- src/Ormolu/Printer/Meat/Common.hs +39/−61
- src/Ormolu/Printer/Meat/Declaration.hs +80/−75
- src/Ormolu/Printer/Meat/Declaration/Annotation.hs +3/−4
- src/Ormolu/Printer/Meat/Declaration/Class.hs +20/−23
- src/Ormolu/Printer/Meat/Declaration/Data.hs +57/−65
- src/Ormolu/Printer/Meat/Declaration/Default.hs +2/−3
- src/Ormolu/Printer/Meat/Declaration/Foreign.hs +4/−6
- src/Ormolu/Printer/Meat/Declaration/Instance.hs +15/−18
- src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs +3/−4
- src/Ormolu/Printer/Meat/Declaration/Rule.hs +8/−10
- src/Ormolu/Printer/Meat/Declaration/Signature.hs +45/−51
- src/Ormolu/Printer/Meat/Declaration/Splice.hs +1/−2
- src/Ormolu/Printer/Meat/Declaration/Type.hs +4/−3
- src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs +17/−14
- src/Ormolu/Printer/Meat/Declaration/Value.hs +305/−316
- src/Ormolu/Printer/Meat/Declaration/Warning.hs +7/−7
- src/Ormolu/Printer/Meat/ImportExport.hs +5/−6
- src/Ormolu/Printer/Meat/Module.hs +7/−7
- src/Ormolu/Printer/Meat/Type.hs +68/−52
- src/Ormolu/Printer/Operators.hs +17/−14
- src/Ormolu/Printer/SpanStream.hs +9/−6
- src/Ormolu/Processing/Common.hs +0/−15
- src/Ormolu/Processing/Cpp.hs +16/−16
- src/Ormolu/Processing/Preprocess.hs +7/−4
- src/Ormolu/Utils.hs +20/−12
- src/Ormolu/Utils/Extensions.hs +8/−8
- tests/Ormolu/Diff/TextSpec.hs +2/−2
- tests/Ormolu/PrinterSpec.hs +22/−5
CHANGELOG.md view
@@ -1,11 +1,50 @@+## Ormolu 0.4.0.0++* When a guard is located on its own line, the body associated with this+ guard is indented by one extra level, so that it can easily be+ distinguished from the guard predicate or pattern. [Issue+ 806](https://github.com/tweag/ormolu/issues/806).++* Now a space is forced after `--` in line comments. [Issue+ 808](https://github.com/tweag/ormolu/issues/808).++* Allow formatting Backpack signature files (`.hsig`). The switch between+ regular module mode and signature mode is based on the file extension by+ default, but can be overridden with the `-t / --source-type` command line+ option. [Issue 600](https://github.com/tweag/ormolu/issues/600).++* Blank Haddock comments are now eliminated. This also fixes issues with+ differing ASTs in some special cases. [Issue+ 726](https://github.com/tweag/ormolu/issues/726).++* Rewrite rules that are never active are now formatted correctly.+ [Issue 823](https://github.com/tweag/ormolu/issues/823).++* Promoted infix data constructors are now formatted correctly. [Issue 768](+ https://github.com/tweag/ormolu/issues/768).++* Switched to `ghc-lib-parser-9.2`.+ [Issue 794](https://github.com/tweag/ormolu/issues/794).+ * Support for the new syntax-related language extensions:+ `OverloadedRecordDot` and `OverloadedRecordUpdate`+ (disabled by default).+ [Issue 709](https://github.com/tweag/ormolu/issues/709).+ * Removed support for `record-dot-preprocessor`. For the getter syntax,+ consider using `OverloadedRecordDot` instead. [Issue+ 659](https://github.com/tweag/ormolu/issues/659). [Issue+ 705](https://github.com/tweag/ormolu/issues/705).+ * Support for the `GHC2021` language.+ ## Ormolu 0.3.1.0 * Allow check mode when working with stdin input. [Issue 634]( https://github.com/tweag/ormolu/issues/634).+ * Now guards are printed on a new line if at least one guard is multiline or if all guards together occupy more than one line. The body of each guard is also indented one level deeper in that case. [Issue 712](https://github.com/tweag/ormolu/issues/712).+ * Invalid Haddock comments are no longer silently deleted, but rather converted into regular comments. [Issue 474](https://github.com/tweag/ormolu/issues/474).
CONTRIBUTING.md view
@@ -39,6 +39,9 @@ Please note that we try to keep individual files at most 25 lines long because otherwise it's hard to figure out want went wrong when a test fails. +To regenerate outputs that have changed, you can set the+`ORMOLU_REGENERATE_EXAMPLES` environment variable before running tests.+ ## CI We use Circle CI. Some outside contributors may have problems, as in, CI
README.md view
@@ -9,7 +9,9 @@ * [Installation](#installation) * [Building from source](#building-from-source) * [Usage](#usage)+ * [Ormolu Live](#ormolu-live) * [Editor integration](#editor-integration)+ * [Haskell Language Server](#haskell-language-server) * [GitHub actions](#github-actions) * [Magic comments](#magic-comments) * [Account for .cabal files](#account-for-cabal-files)@@ -39,6 +41,9 @@ * Be well-tested and robust so that the formatter can be used in large projects. +Try it out in your browser at <https://ormolu-live.tweag.io>!+See [Ormolu Live](#ormolu-live) for more info.+ ## Installation The [release page][releases] has binaries for Linux, macOS and Windows.@@ -132,6 +137,12 @@ https://www.git-scm.com/docs/git-config#Documentation/git-config.txt-coreautocrlf) to `false`. +### Ormolu Live++On every new commit to `master`, [Ormolu Live](./ormolu-live) is deployed to+https://ormolu-live.tweag.io. Older versions are available at+https://COMMITHASH--ormolu-live.netlify.app.+ ### Editor integration We know of the following editor integrations:@@ -139,6 +150,11 @@ * [Emacs][emacs-package] * [VS Code][vs-code-plugin] * Vim: [neoformat][neoformat], [vim-ormolu][vim-ormolu]++### Haskell Language Server++[Haskell Language Server](https://haskell-language-server.readthedocs.io)+has built-in support for using Ormolu as a formatter. ### GitHub actions
app/Main.hs view
@@ -10,7 +10,7 @@ import Control.Monad import Data.Bool (bool) import Data.List (intercalate, sort)-import Data.Maybe (mapMaybe)+import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Text as T import qualified Data.Text.IO as TIO import Data.Version (showVersion)@@ -32,7 +32,12 @@ main :: IO () main = do Opts {..} <- execParser optsParserInfo- let formatOne' = formatOne optCabalDefaultExtensions optMode optConfig+ let formatOne' =+ formatOne+ optCabalDefaultExtensions+ optMode+ optSourceType+ optConfig exitCode <- case optInputFiles of [] -> formatOne' Nothing ["-"] -> formatOne' Nothing@@ -59,18 +64,20 @@ CabalDefaultExtensionsOpts -> -- | Mode of operation Mode ->+ -- | The 'SourceType' requested by the user+ Maybe SourceType -> -- | Configuration Config RegionIndices -> -- | File to format or stdin as 'Nothing' Maybe FilePath -> IO ExitCode-formatOne CabalDefaultExtensionsOpts {..} mode config mpath =- withPrettyOrmoluExceptions (cfgColorMode config) $+formatOne CabalDefaultExtensionsOpts {..} mode reqSourceType rawConfig mpath =+ withPrettyOrmoluExceptions (cfgColorMode rawConfig) $ do case FP.normalise <$> mpath of -- input source = STDIN Nothing -> do resultConfig <-- configPlus+ patchConfig Nothing <$> if optUseCabalDefaultExtensions then case optStdinInputFile of Just stdinInputFile ->@@ -97,7 +104,7 @@ -- input source = a file Just inputFile -> do resultConfig <-- configPlus+ patchConfig (Just (detectSourceType inputFile)) <$> if optUseCabalDefaultExtensions then getCabalExtensionDynOptions inputFile else pure []@@ -108,22 +115,31 @@ InPlace -> do -- ormoluFile is not used because we need originalInput originalInput <- readFileUtf8 inputFile- formattedInput <- ormolu resultConfig inputFile (T.unpack originalInput)+ formattedInput <-+ ormolu resultConfig inputFile (T.unpack originalInput) when (formattedInput /= originalInput) $ writeFileUtf8 inputFile formattedInput return ExitSuccess Check -> do -- ormoluFile is not used because we need originalInput originalInput <- readFileUtf8 inputFile- formattedInput <- ormolu resultConfig inputFile (T.unpack originalInput)+ formattedInput <-+ ormolu resultConfig inputFile (T.unpack originalInput) handleDiff originalInput formattedInput inputFile where- configPlus dynOpts = config {cfgDynOptions = cfgDynOptions config ++ dynOpts}+ patchConfig mdetectedSourceType dynOpts =+ rawConfig+ { cfgDynOptions = cfgDynOptions rawConfig ++ dynOpts,+ cfgSourceType =+ fromMaybe+ ModuleSource+ (reqSourceType <|> mdetectedSourceType)+ } handleDiff originalInput formattedInput fileRepr = case diffText originalInput formattedInput fileRepr of Nothing -> return ExitSuccess Just diff -> do- runTerm (printTextDiff diff) (cfgColorMode config) stderr+ runTerm (printTextDiff diff) (cfgColorMode rawConfig) stderr -- 100 is different to all the other exit code that are emitted -- either from an 'OrmoluException' or from 'error' and -- 'notImplemented'.@@ -139,6 +155,8 @@ optConfig :: !(Config RegionIndices), -- | Options for respecting default-extensions from .cabal files optCabalDefaultExtensions :: CabalDefaultExtensionsOpts,+ -- | Source type option, where 'Nothing' means autodetection+ optSourceType :: !(Maybe SourceType), -- | Haskell source files to format or stdin (when the list is empty) optInputFiles :: ![FilePath] }@@ -213,6 +231,7 @@ ) <*> configParser <*> cabalDefaultExtensionsParser+ <*> sourceTypeParser <*> (many . strArgument . mconcat) [ metavar "FILE", help "Haskell source files to format or stdin (the default)"@@ -255,6 +274,10 @@ short 'c', help "Fail if formatting is not idempotent" ]+ -- We cannot parse the source type here, because we might need to do+ -- autodection based on the input file extension (not available here)+ -- before storing the resolved value in the config struct.+ <*> pure ModuleSource <*> (option parseColorMode . mconcat) [ long "color", metavar "WHEN",@@ -274,6 +297,16 @@ ] ) +sourceTypeParser :: Parser (Maybe SourceType)+sourceTypeParser =+ (option parseSourceType . mconcat)+ [ long "source-type",+ short 't',+ metavar "TYPE",+ value Nothing,+ help "Set the type of source; TYPE can be 'module', 'sig', or 'auto' (the default)"+ ]+ ---------------------------------------------------------------------------- -- Helpers @@ -285,9 +318,19 @@ "check" -> Right Check s -> Left $ "unknown mode: " ++ s +-- | Parse 'ColorMode'. parseColorMode :: ReadM ColorMode parseColorMode = eitherReader $ \case "never" -> Right Never "always" -> Right Always "auto" -> Right Auto s -> Left $ "unknown color mode: " ++ s++-- | Parse the 'SourceType'. 'Nothing' means that autodetection based on+-- file extension is requested.+parseSourceType :: ReadM (Maybe SourceType)+parseSourceType = eitherReader $ \case+ "module" -> Right (Just ModuleSource)+ "sig" -> Right (Just SignatureSource)+ "auto" -> Right Nothing+ s -> Left $ "unknown source type: " ++ s
+ data/examples/declaration/rewrite-rule/never-active-out.hs view
@@ -0,0 +1,1 @@+{-# RULES "map-loop" [~] forall f. map' f = map' (id . f) #-}
+ data/examples/declaration/rewrite-rule/never-active.hs view
@@ -0,0 +1,1 @@+{-# RULES "map-loop" [ ~ ] forall f . map' f = map' (id . f) #-}
data/examples/declaration/type/promotion-1-out.hs view
@@ -13,3 +13,5 @@ type E = TypeError ('Text "Some text") type G = '[ '( 'Just, 'Bool)]++type X = () '`PromotedInfix` ()
data/examples/declaration/type/promotion-1.hs view
@@ -7,3 +7,5 @@ type E = TypeError ('Text "Some text") type G = '[ '( 'Just, 'Bool) ]++type X = () '`PromotedInfix` ()
data/examples/declaration/value/function/arrow/proc-do-complex-out.hs view
@@ -29,7 +29,8 @@ Left ( z, w- ) -> \u -> -- Procs can have lambdas+ ) -> \u ->+ -- Procs can have lambdas let v = u -- Actually never used ^ 2
data/examples/declaration/value/function/arrow/proc-lambdas-out.hs view
@@ -5,5 +5,6 @@ bar = proc x -> \f g h -> \() ->- \(Left (x, y)) -> -- Tuple value+ \(Left (x, y)) ->+ -- Tuple value f (g (h x)) -< y
data/examples/declaration/value/function/case-multi-line-guards-out.hs view
@@ -3,8 +3,8 @@ case x of x | x > 10 ->- foo- + bar+ foo+ + bar x | x > 5 -> 10 _ -> 20
data/examples/declaration/value/function/multi-way-if-out.hs view
@@ -6,7 +6,7 @@ if | x > y -> x | x < y ->- y+ y | otherwise -> x baz =
data/examples/declaration/value/function/multiple-guards-out.hs view
@@ -6,9 +6,9 @@ bar :: Int -> Int bar x | x == 5 =- foo x- + foo 10+ foo x+ + foo 10 | x == 6 =- foo x- + foo 20+ foo x+ + foo 20 | otherwise = foo 100
data/examples/declaration/value/function/operators-2-out.hs view
@@ -1,4 +1,4 @@ foo n | x || y && z || n ** x || x && n =- 42+ 42
data/examples/declaration/value/function/pattern/multiline-guard-statement-out.hs view
@@ -2,5 +2,5 @@ foobarbar | x <- 5 = case x of- 5 -> True- _ -> False+ 5 -> True+ _ -> False
data/examples/declaration/value/function/pattern/multiple-guard-statements-out.hs view
@@ -2,5 +2,5 @@ foobarbar | x <- 5, y <- 6 = case x of- 5 -> True- _ -> False+ 5 -> True+ _ -> False
− data/examples/declaration/value/function/record/dot-multiline-out.hs
@@ -1,15 +0,0 @@-{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}--bar' =- (Foo 1){bar = 2- }--fooplus'''' f n =- f{foo = n,- bar = n- }--fooplus''''' f n =- f- { foo = n- }
− data/examples/declaration/value/function/record/dot-multiline.hs
@@ -1,10 +0,0 @@-{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}-bar' = (Foo 1){bar = 2- }--fooplus'''' f n = f{foo = n,- bar = n- }--fooplus''''' f n = f- { foo = n }
− data/examples/declaration/value/function/record/dot-singleline-out.hs
@@ -1,15 +0,0 @@-{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}--data Foo = Foo {bar :: Int}--mfoo = fmap (.bar) $ Nothing--bar = (Foo 1).bar--fooplus f n = f{foo = f.bar + n}--fooplus' f n = f {foo = f.bar + n}--fooplus'' f n = f {foo = f.bar + n}--fooplus''' f n = f {foo = f.bar + n}
− data/examples/declaration/value/function/record/dot-singleline.hs
@@ -1,14 +0,0 @@-{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}-data Foo = Foo { bar :: Int }--mfoo = fmap (.bar) $ Nothing--bar = ( Foo 1).bar--fooplus f n = f{foo = f.bar + n}--fooplus' f n = f { foo = f.bar + n}--fooplus'' f n = f {foo = f.bar + n}--fooplus''' f n = f{ foo = f.bar + n}
+ data/examples/declaration/value/function/record/record-dot-out.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedRecordUpdate #-}++data Foo = Foo {bar :: Foo}++mfoo = fmap (.bar) $ Nothing++bar = (Foo 1).bar++fooplus f n = f {foo = f.bar + n}++nestedFoo f = f.bar.bar.bar.bar.bar++nestedFooUpdate f = f {bar.bar = f.bar} <> f {bar.bar.bar.bar}++operatorUpdate f = f {(+) = 1}
+ data/examples/declaration/value/function/record/record-dot.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedRecordUpdate #-}++data Foo = Foo { bar :: Foo }++mfoo = fmap (.bar) $ Nothing++bar = ( Foo 1).bar++fooplus f n = f{foo = f.bar + n}++nestedFoo f = f.bar.bar.bar.bar.bar++nestedFooUpdate f = f {bar.bar = f.bar } <> f {bar.bar.bar.bar}++operatorUpdate f = f { (+) = 1 }
+ data/examples/module-header/empty-haddock-out.hs view
@@ -0,0 +1,1 @@+module Test where
+ data/examples/module-header/empty-haddock.hs view
@@ -0,0 +1,3 @@+-- |+--+module Test where
+ data/examples/other/comment-spacing-out.hs view
@@ -0,0 +1,7 @@+-- | Something.+foo ::+ -- | Foo.+ Int ->+ -- | Bar.+ IO ()+foo _ = pure () -- comment
+ data/examples/other/comment-spacing.hs view
@@ -0,0 +1,7 @@+-- |Something.+foo ::+ -- |Foo.+ Int ->+ -- |Bar.+ IO ()+foo _ = pure () --comment
data/examples/other/empty-haddock-out.hs view
@@ -1,5 +1,7 @@-module Main where+module Test+ ( test,+ )+where --- |-foo :: Int-foo = 5+test ::+ test
data/examples/other/empty-haddock.hs view
@@ -1,6 +1,11 @@-module Main where- -- |+module Test+ ( -- |+ test,+ )+where -foo :: Int-foo = 5+-- |+test ::+ -- |+ test
− data/examples/other/no-linear-arrows-out.hs
@@ -1,5 +0,0 @@-type a % b = (a, b)--type Foo a m b = a % m -> b--type Bar a m b = a % m -> b
− data/examples/other/no-linear-arrows.hs
@@ -1,4 +0,0 @@-type a % b = (a,b)--type Foo a m b = a % m -> b-type Bar a m b = a %m -> b
ormolu.cabal view
@@ -1,10 +1,10 @@ cabal-version: 2.4 name: ormolu-version: 0.3.1.0+version: 0.4.0.0 license: BSD-3-Clause license-file: LICENSE.md maintainer: Mark Karpov <mark.karpov@tweag.io>-tested-with: ghc ==8.8.4 ghc ==8.10.7 ghc ==9.0.1+tested-with: ghc ==8.10.7 ghc ==9.0.1 ghc ==9.2.1 homepage: https://github.com/tweag/ormolu bug-reports: https://github.com/tweag/ormolu/issues synopsis: A formatter for Haskell source code@@ -39,7 +39,6 @@ Ormolu.Exception Ormolu.Imports Ormolu.Parser- Ormolu.Parser.Anns Ormolu.Parser.CommentStream Ormolu.Parser.Pragma Ormolu.Parser.Result@@ -83,18 +82,19 @@ build-depends: Diff >=0.4 && <1.0, ansi-terminal >=0.10 && <1.0,- base >=4.12 && <5.0,+ base >=4.14 && <5.0, bytestring >=0.2 && <0.12, containers >=0.5 && <0.7, dlist >=0.8 && <2.0,+ array >=0.5 && <0.6, exceptions >=0.6 && <0.11,- ghc-lib-parser >=9.0 && <9.1,+ ghc-lib-parser >=9.2 && <9.3, mtl >=2.0 && <3.0, syb >=0.7 && <0.8, text >=0.2 && <1.3, filepath >=1.2 && <1.5, directory ^>=1.3,- Cabal ^>=3.4+ Cabal >=3.6 && <3.7 if flag(dev) ghc-options:@@ -105,9 +105,6 @@ else ghc-options: -O2 -Wall - if impl(ghc <8.10.0)- ghc-options: -fmax-pmcheck-iterations=3000000- executable ormolu main-is: Main.hs hs-source-dirs: app@@ -117,7 +114,7 @@ build-depends: base >=4.12 && <5.0, filepath >=1.2 && <1.5,- ghc-lib-parser >=9.0 && <9.1,+ ghc-lib-parser >=9.2 && <9.3, gitrev >=1.3 && <1.4, optparse-applicative >=0.14 && <0.17, ormolu,@@ -147,7 +144,7 @@ default-language: Haskell2010 build-depends:- base >=4.12 && <5.0,+ base >=4.14 && <5.0, containers >=0.5 && <0.7, directory ^>=1.3, filepath >=1.2 && <1.5,
src/GHC/DynFlags.hs view
@@ -24,12 +24,12 @@ sFileSettings = FileSettings {}, sTargetPlatform = Platform- { platformWordSize = PW8,- platformMini =- PlatformMini- { platformMini_arch = ArchUnknown,- platformMini_os = OSUnknown+ { platformArchOS =+ ArchOS+ { archOS_arch = ArchUnknown,+ archOS_OS = OSUnknown },+ platformWordSize = PW8, platformUnregisterised = True, platformByteOrder = LittleEndian, platformHasGnuNonexecStack = False,@@ -37,11 +37,10 @@ platformHasSubsectionsViaSymbols = False, platformIsCrossCompiling = False, platformLeadingUnderscore = False,- platformTablesNextToCode = False+ platformTablesNextToCode = False,+ platform_constants = Nothing }, sPlatformMisc = PlatformMisc {},- sPlatformConstants =- PlatformConstants {pc_DYNAMIC_BY_DEFAULT = False, pc_WORD_SIZE = 8}, sToolSettings = ToolSettings { toolSettings_opt_P_fingerprint = fingerprint0,
src/Ormolu.hs view
@@ -9,7 +9,9 @@ Config (..), ColorMode (..), RegionIndices (..),+ SourceType (..), defaultConfig,+ detectSourceType, DynOption (..), OrmoluException (..), withPrettyOrmoluExceptions,@@ -29,10 +31,12 @@ import Ormolu.Diff.Text import Ormolu.Exception import Ormolu.Parser+import Ormolu.Parser.CommentStream (showCommentStream) import Ormolu.Parser.Result import Ormolu.Printer import Ormolu.Utils (showOutputable) import Ormolu.Utils.IO+import System.FilePath -- | Format a 'String', return formatted version as 'Text'. --@@ -44,6 +48,10 @@ -- side-effects though. -- * Takes file name just to use it in parse error messages. -- * Throws 'OrmoluException'.+--+-- __NOTE__: The caller is responsible for setting the appropriate value in+-- the 'cfgSourceType' field. Autodetection of source type won't happen+-- here, see 'detectSourceType'. ormolu :: MonadIO m => -- | Ormolu configuration@@ -61,11 +69,14 @@ when (cfgDebug cfg) $ do traceM "warnings:\n" traceM (concatMap showWarn warnings)+ forM_ result0 $ \case+ ParsedSnippet r -> traceM . showCommentStream . prCommentStream $ r+ _ -> pure () -- We're forcing 'txt' here because otherwise errors (such as messages -- about not-yet-supported functionality) will be thrown later when we try -- to parse the rendered code back, inside of GHC monad wrapper which will -- lead to error messages presenting the exceptions as GHC bugs.- let !txt = printModule result0+ let !txt = printSnippets result0 when (not (cfgUnsafe cfg) || cfgCheckIdempotence cfg) $ do -- Parse the result of pretty-printing again and make sure that AST -- is the same as AST of original snippet module span positions.@@ -87,7 +98,7 @@ -- Try re-formatting the formatted result to check if we get exactly -- the same output. when (cfgCheckIdempotence cfg) $- let txt2 = printModule result1+ let txt2 = printSnippets result1 in case diffText txt txt2 path of Nothing -> return () Just diff ->@@ -97,6 +108,10 @@ -- | Load a file and format it. The file stays intact and the rendered -- version is returned as 'Text'.+--+-- __NOTE__: The caller is responsible for setting the appropriate value in+-- the 'cfgSourceType' field. Autodetection of source type won't happen+-- here, see 'detectSourceType'. ormoluFile :: MonadIO m => -- | Ormolu configuration@@ -109,6 +124,10 @@ readFileUtf8 path >>= ormolu cfg path . T.unpack -- | Read input from stdin and format it.+--+-- __NOTE__: The caller is responsible for setting the appropriate value in+-- the 'cfgSourceType' field. Autodetection of source type won't happen+-- here, see 'detectSourceType'. ormoluStdin :: MonadIO m => -- | Ormolu configuration@@ -146,3 +165,10 @@ [ showOutputable reason, showOutputable l ]++-- | Detect 'SourceType' based on the file extension.+detectSourceType :: FilePath -> SourceType+detectSourceType mpath =+ if takeExtension mpath == ".hsig"+ then SignatureSource+ else ModuleSource
src/Ormolu/Config.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} -- | Configuration options used by the tool.@@ -7,6 +8,7 @@ ColorMode (..), RegionIndices (..), RegionDeltas (..),+ SourceType (..), defaultConfig, regionIndicesToDeltas, DynOption (..),@@ -14,9 +16,18 @@ ) where +import GHC.Generics (Generic) import qualified GHC.Types.SrcLoc as GHC import Ormolu.Terminal (ColorMode (..)) +-- | Type of sources that can be formatted by Ormolu.+data SourceType+ = -- | Consider the input as a regular Haskell module+ ModuleSource+ | -- | Consider the input as a Backpack module signature+ SignatureSource+ deriving (Eq, Show)+ -- | Ormolu configuration. data Config region = Config { -- | Dynamic options to pass to GHC parser@@ -27,12 +38,14 @@ cfgDebug :: !Bool, -- | Checks if re-formatting the result is idempotent cfgCheckIdempotence :: !Bool,+ -- | How to parse the input (regular haskell module or Backpack file)+ cfgSourceType :: !SourceType, -- | Whether to use colors and other features of ANSI terminals cfgColorMode :: !ColorMode, -- | Region selection cfgRegion :: !region }- deriving (Eq, Show, Functor)+ deriving (Eq, Show, Functor, Generic) -- | Region selection as the combination of start and end line numbers. data RegionIndices = RegionIndices@@ -61,6 +74,7 @@ cfgUnsafe = False, cfgDebug = False, cfgCheckIdempotence = False,+ cfgSourceType = ModuleSource, cfgColorMode = Auto, cfgRegion = RegionIndices
src/Ormolu/Diff/ParseResult.hs view
@@ -19,9 +19,8 @@ import Data.Foldable import Data.Generics import GHC.Hs-import GHC.Types.Basic+import GHC.Types.SourceText import GHC.Types.SrcLoc-import Ormolu.Imports (normalizeImports) import Ormolu.Parser.CommentStream import Ormolu.Parser.Result import Ormolu.Utils@@ -32,6 +31,7 @@ Same | -- | Two parse results differ Different [SrcSpan]+ deriving (Show) instance Semigroup ParseResultDiff where Same <> a = a@@ -56,9 +56,7 @@ prParsedSource = hs1 } = diffCommentStream cstream0 cstream1- <> matchIgnoringSrcSpans- hs0 {hsmodImports = normalizeImports (hsmodImports hs0)}- hs1 {hsmodImports = normalizeImports (hsmodImports hs1)}+ <> matchIgnoringSrcSpans hs0 hs1 diffCommentStream :: CommentStream -> CommentStream -> ParseResultDiff diffCommentStream (CommentStream cs) (CommentStream cs')@@ -73,6 +71,8 @@ -- * ordering of import lists -- * style (ASCII vs Unicode) of arrows -- * LayoutInfo (brace style) in extension fields+-- * Empty contexts in type classes+-- * Parens around derived type classes matchIgnoringSrcSpans :: Data a => a -> a -> ParseResultDiff matchIgnoringSrcSpans a = genericQuery a where@@ -82,27 +82,33 @@ -- implement 'toConstr', so we have to deal with it in a special way. | Just x' <- cast x, Just y' <- cast y =- if x' == (y' :: ByteString)- then Same- else Different []+ if x' == (y' :: ByteString)+ then Same+ else Different [] | typeOf x == typeOf y, toConstr x == toConstr y =- mconcat $- gzipWithQ- ( genericQuery- `extQ` srcSpanEq- `extQ` sourceTextEq- `extQ` hsDocStringEq- `extQ` importDeclQualifiedStyleEq- `extQ` unicodeArrowStyleEq- `extQ` layoutInfoEq- `ext2Q` forLocated- )- x- y+ mconcat $+ gzipWithQ+ ( genericQuery+ `extQ` srcSpanEq+ `ext1Q` epAnnEq+ `extQ` sourceTextEq+ `extQ` hsDocStringEq+ `extQ` importDeclQualifiedStyleEq+ `extQ` unicodeArrowStyleEq+ `extQ` layoutInfoEq+ `extQ` classDeclCtxEq+ `extQ` derivedTyClsParensEq+ `extQ` epaCommentsEq+ `ext2Q` forLocated+ )+ x+ y | otherwise = Different [] srcSpanEq :: SrcSpan -> GenericQ ParseResultDiff srcSpanEq _ _ = Same+ epAnnEq :: EpAnn a -> GenericQ ParseResultDiff+ epAnnEq _ _ = Same sourceTextEq :: SourceText -> GenericQ ParseResultDiff sourceTextEq _ _ = Same importDeclQualifiedStyleEq ::@@ -127,7 +133,7 @@ GenLocated e0 e1 -> GenericQ ParseResultDiff forLocated x@(L mspn _) y =- maybe id appendSpan (cast mspn) (genericQuery x y)+ maybe id appendSpan (cast `ext1Q` (Just . locA) $ mspn) (genericQuery x y) appendSpan :: SrcSpan -> ParseResultDiff -> ParseResultDiff appendSpan s (Different ss) | fresh && helpful = Different (s : ss) where@@ -137,8 +143,8 @@ -- as we normalize arrow styles (e.g. -> vs →), we consider them equal here unicodeArrowStyleEq :: HsArrow GhcPs -> GenericQ ParseResultDiff unicodeArrowStyleEq (HsUnrestrictedArrow _) (castArrow -> Just (HsUnrestrictedArrow _)) = Same- unicodeArrowStyleEq (HsLinearArrow _) (castArrow -> Just (HsLinearArrow _)) = Same- unicodeArrowStyleEq (HsExplicitMult _ t) (castArrow -> Just (HsExplicitMult _ t')) = genericQuery t t'+ unicodeArrowStyleEq (HsLinearArrow _ _) (castArrow -> Just (HsLinearArrow _ _)) = Same+ unicodeArrowStyleEq (HsExplicitMult _ _ t) (castArrow -> Just (HsExplicitMult _ _ t')) = genericQuery t t' unicodeArrowStyleEq _ _ = Different [] castArrow :: Typeable a => a -> Maybe (HsArrow GhcPs) castArrow = cast@@ -146,3 +152,13 @@ layoutInfoEq :: LayoutInfo -> GenericQ ParseResultDiff layoutInfoEq _ (cast -> Just (_ :: LayoutInfo)) = Same layoutInfoEq _ _ = Different []+ classDeclCtxEq :: TyClDecl GhcPs -> GenericQ ParseResultDiff+ classDeclCtxEq ClassDecl {tcdCtxt = Just (L _ []), ..} tc' = genericQuery ClassDecl {tcdCtxt = Nothing, ..} tc'+ classDeclCtxEq tc tc' = genericQuery tc tc'+ derivedTyClsParensEq :: DerivClauseTys GhcPs -> GenericQ ParseResultDiff+ derivedTyClsParensEq (DctSingle NoExtField sigTy) dct' = genericQuery (DctMulti NoExtField [sigTy]) dct'+ derivedTyClsParensEq dct dct' = genericQuery dct dct'+ -- EpAnnComments ~ XCGRHSs GhcPs+ epaCommentsEq :: EpAnnComments -> GenericQ ParseResultDiff+ epaCommentsEq _ (cast -> Just (_ :: EpAnnComments)) = Same+ epaCommentsEq _ _ = Different []
src/Ormolu/Imports.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-} -- | Manipulations on import lists. module Ormolu.Imports@@ -14,11 +15,11 @@ import Data.List (foldl', nubBy, sortBy, sortOn) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M-import GHC.Data.FastString (FastString)-import GHC.Hs.Extension+import GHC.Data.FastString+import GHC.Hs import GHC.Hs.ImpExp as GHC-import GHC.Types.Basic import GHC.Types.Name.Reader+import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Unit.Module.Name import GHC.Unit.Types@@ -32,6 +33,7 @@ . M.fromListWith combineImports . fmap (\x -> (importId x, g x)) where+ g :: LImportDecl GhcPs -> LImportDecl GhcPs g (L l ImportDecl {..}) = L l@@ -63,7 +65,7 @@ data ImportId = ImportId { importIsPrelude :: Bool, importIdName :: ModuleName,- importPkgQual :: Maybe FastString,+ importPkgQual :: Maybe LexicalFastString, importSource :: IsBootInterface, importSafe :: Bool, importQualified :: Bool,@@ -79,7 +81,7 @@ ImportId { importIsPrelude = isPrelude, importIdName = moduleName,- importPkgQual = sl_fs <$> ideclPkgQual,+ importPkgQual = LexicalFastString . sl_fs <$> ideclPkgQual, importSource = ideclSource, importSafe = ideclSafe, importQualified = case ideclQualified of@@ -109,39 +111,38 @@ alter = \case Nothing -> Just . L new_l $ case new of- IEThingWith NoExtField n wildcard g flbl ->- IEThingWith NoExtField n wildcard (normalizeWNames g) flbl+ IEThingWith _ n wildcard g ->+ IEThingWith EpAnnNotUsed n wildcard (normalizeWNames g) other -> other Just old -> let f = \case- IEVar NoExtField n -> IEVar NoExtField n- IEThingAbs NoExtField _ -> new- IEThingAll NoExtField n -> IEThingAll NoExtField n- IEThingWith NoExtField n wildcard g flbl ->+ IEVar _ n -> IEVar NoExtField n+ IEThingAbs _ _ -> new+ IEThingAll _ n -> IEThingAll EpAnnNotUsed n+ IEThingWith _ n wildcard g -> case new of IEVar NoExtField _ -> error "Ormolu.Imports broken presupposition"- IEThingAbs NoExtField _ ->- IEThingWith NoExtField n wildcard g flbl- IEThingAll NoExtField n' ->- IEThingAll NoExtField n'- IEThingWith NoExtField n' wildcard' g' flbl' ->+ IEThingAbs _ _ ->+ IEThingWith EpAnnNotUsed n wildcard g+ IEThingAll _ n' ->+ IEThingAll EpAnnNotUsed n'+ IEThingWith _ n' wildcard' g' -> let combinedWildcard = case (wildcard, wildcard') of (IEWildcard _, _) -> IEWildcard 0 (_, IEWildcard _) -> IEWildcard 0 _ -> NoIEWildcard in IEThingWith- NoExtField+ EpAnnNotUsed n' combinedWildcard (normalizeWNames (g <> g'))- flbl'- IEModuleContents NoExtField _ -> notImplemented "IEModuleContents"+ IEModuleContents _ _ -> notImplemented "IEModuleContents" IEGroup NoExtField _ _ -> notImplemented "IEGroup" IEDoc NoExtField _ -> notImplemented "IEDoc" IEDocNamed NoExtField _ -> notImplemented "IEDocNamed"- IEModuleContents NoExtField _ -> notImplemented "IEModuleContents"+ IEModuleContents _ _ -> notImplemented "IEModuleContents" IEGroup NoExtField _ _ -> notImplemented "IEGroup" IEDoc NoExtField _ -> notImplemented "IEDoc" IEDocNamed NoExtField _ -> notImplemented "IEDocNamed"@@ -160,10 +161,10 @@ getIewn :: IE GhcPs -> IEWrappedNameOrd getIewn = \case IEVar NoExtField x -> IEWrappedNameOrd (unLoc x)- IEThingAbs NoExtField x -> IEWrappedNameOrd (unLoc x)- IEThingAll NoExtField x -> IEWrappedNameOrd (unLoc x)- IEThingWith NoExtField x _ _ _ -> IEWrappedNameOrd (unLoc x)- IEModuleContents NoExtField _ -> notImplemented "IEModuleContents"+ IEThingAbs _ x -> IEWrappedNameOrd (unLoc x)+ IEThingAll _ x -> IEWrappedNameOrd (unLoc x)+ IEThingWith _ x _ _ -> IEWrappedNameOrd (unLoc x)+ IEModuleContents _ _ -> notImplemented "IEModuleContents" IEGroup NoExtField _ _ -> notImplemented "IEGroup" IEDoc NoExtField _ -> notImplemented "IEDoc" IEDocNamed NoExtField _ -> notImplemented "IEDocNamed"@@ -175,14 +176,14 @@ -- | Compare two @'IEWrapppedName' 'RdrName'@ things. compareIewn :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering compareIewn (IEName x) (IEName y) = unLoc x `compareRdrName` unLoc y-compareIewn (IEName _) (IEPattern _) = LT-compareIewn (IEName _) (IEType _) = LT-compareIewn (IEPattern _) (IEName _) = GT-compareIewn (IEPattern x) (IEPattern y) = unLoc x `compareRdrName` unLoc y-compareIewn (IEPattern _) (IEType _) = LT-compareIewn (IEType _) (IEName _) = GT-compareIewn (IEType _) (IEPattern _) = GT-compareIewn (IEType x) (IEType y) = unLoc x `compareRdrName` unLoc y+compareIewn (IEName _) (IEPattern _ _) = LT+compareIewn (IEName _) (IEType _ _) = LT+compareIewn (IEPattern _ _) (IEName _) = GT+compareIewn (IEPattern _ x) (IEPattern _ y) = unLoc x `compareRdrName` unLoc y+compareIewn (IEPattern _ _) (IEType _ _) = LT+compareIewn (IEType _ _) (IEName _) = GT+compareIewn (IEType _ _) (IEPattern _ _) = GT+compareIewn (IEType _ x) (IEType _ y) = unLoc x `compareRdrName` unLoc y compareRdrName :: RdrName -> RdrName -> Ordering compareRdrName x y =
src/Ormolu/Parser.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Parser for Haskell source code.@@ -12,7 +14,9 @@ import Control.Exception import Control.Monad.Except+import Data.Char (isSpace) import Data.Functor+import Data.Generics import qualified Data.List as L import qualified Data.List.NonEmpty as NE import Data.Ord (Down (Down))@@ -22,19 +26,20 @@ import qualified GHC.Data.StringBuffer as GHC import qualified GHC.Driver.CmdLine as GHC import GHC.Driver.Session as GHC-import qualified GHC.Driver.Types as GHC import GHC.DynFlags (baseDynFlags)+import GHC.Hs hiding (UnicodeSyntax) import GHC.LanguageExtensions.Type (Extension (..)) import qualified GHC.Parser as GHC+import GHC.Parser.Errors.Ppr (pprError) import qualified GHC.Parser.Header as GHC import qualified GHC.Parser.Lexer as GHC+import qualified GHC.Types.SourceError as GHC (handleSourceError) import GHC.Types.SrcLoc-import GHC.Unit.Module.Name import GHC.Utils.Error (Severity (..), errMsgSeverity, errMsgSpan) import qualified GHC.Utils.Panic as GHC import Ormolu.Config import Ormolu.Exception-import Ormolu.Parser.Anns+import Ormolu.Imports (normalizeImports) import Ormolu.Parser.CommentStream import Ormolu.Parser.Result import Ormolu.Processing.Common@@ -89,25 +94,23 @@ m (Either (SrcSpan, String) ParseResult) parseModuleSnippet Config {..} dynFlags path rawInput = liftIO $ do let (input, indent) = removeIndentation . linesInRegion cfgRegion $ rawInput- let useRecordDot =- "record-dot-preprocessor" == pgm_F dynFlags- || any- (("RecordDotPreprocessor" ==) . moduleNameString)- (pluginModNames dynFlags)- pStateErrors = \pstate ->- let errs = bagToList $ GHC.getErrorMessages pstate dynFlags+ let pStateErrors = \pstate ->+ let errs = fmap pprError . bagToList $ GHC.getErrorMessages pstate fixupErrSpan = incSpanLine (regionPrefixLength cfgRegion) in case L.sortOn (Down . SeverityOrd . errMsgSeverity) errs of [] -> Nothing err : _ -> -- Show instance returns a short error message Just (fixupErrSpan (errMsgSpan err), show err)- r = case runParser GHC.parseModule dynFlags path input of+ parser = case cfgSourceType of+ ModuleSource -> GHC.parseModule+ SignatureSource -> GHC.parseSignature+ r = case runParser parser dynFlags path input of GHC.PFailed pstate -> case pStateErrors pstate of Just err -> Left err Nothing -> error "PFailed does not have an error"- GHC.POk pstate (L _ hsModule) ->+ GHC.POk pstate (L _ (normalizeModule -> hsModule)) -> case pStateErrors pstate of -- Some parse errors (pattern/arrow syntax in expr context) -- do not cause a parse error, but they are replaced with "_"@@ -116,24 +119,54 @@ Just err -> Left err Nothing -> let (stackHeader, pragmas, comments) =- mkCommentStream input pstate hsModule+ mkCommentStream input hsModule in Right ParseResult { prParsedSource = hsModule,- prAnns = mkAnns pstate,+ prSourceType = cfgSourceType, prStackHeader = stackHeader, prPragmas = pragmas, prCommentStream = comments,- prUseRecordDot = useRecordDot, prExtensions = GHC.extensionFlags dynFlags, prIndent = indent } return r +-- | Normalize a 'HsModule' by sorting its import\/export lists, dropping+-- blank comments, etc.+normalizeModule :: HsModule -> HsModule+normalizeModule hsmod =+ everywhere+ (mkT dropBlankTypeHaddocks)+ hsmod+ { hsmodImports =+ normalizeImports (hsmodImports hsmod),+ hsmodDecls =+ filter (not . isBlankDocD . unLoc) (hsmodDecls hsmod),+ hsmodHaddockModHeader =+ mfilter (not . isBlankDocString . unLoc) (hsmodHaddockModHeader hsmod),+ hsmodExports =+ (fmap . fmap) (filter (not . isBlankDocIE . unLoc)) (hsmodExports hsmod)+ }+ where+ isBlankDocString = all isSpace . unpackHDS+ isBlankDocD = \case+ DocD _ s -> isBlankDocString $ docDeclDoc s+ _ -> False+ isBlankDocIE = \case+ IEGroup _ _ s -> isBlankDocString s+ IEDoc _ s -> isBlankDocString s+ _ -> False++ dropBlankTypeHaddocks = \case+ L _ (HsDocTy _ ty (L _ ds)) :: LHsType GhcPs+ | isBlankDocString ds -> ty+ a -> a+ -- | Enable all language extensions that we think should be enabled by -- default for ease of use. setDefaultExts :: DynFlags -> DynFlags-setDefaultExts flags = L.foldl' xopt_set flags autoExts+setDefaultExts flags = L.foldl' xopt_set (lang_set flags (Just Haskell2010)) autoExts where autoExts = allExts L.\\ manualExts allExts = [minBound .. maxBound]@@ -164,7 +197,9 @@ -- decision of enabling this style is left to the user NegativeLiterals, -- with this, `- 1` and `-1` have differing AST LexicalNegation, -- implies NegativeLiterals- LinearTypes -- steals the (%) type operator in some cases+ LinearTypes, -- steals the (%) type operator in some cases+ OverloadedRecordDot, -- f.g parses differently+ OverloadedRecordUpdate -- qualified fields are not supported ] -- | Run a 'GHC.P' computation.@@ -183,7 +218,15 @@ where location = mkRealSrcLoc (GHC.mkFastString filename) 1 1 buffer = GHC.stringToStringBuffer input- parseState = GHC.mkPState flags buffer location+ parseState = GHC.initParserState (opts flags) buffer location+ opts =+ GHC.mkParserOpts+ <$> GHC.warningFlags+ <*> GHC.extensionFlags+ <*> GHC.safeImportsOn+ <*> GHC.gopt GHC.Opt_Haddock+ <*> GHC.gopt GHC.Opt_KeepRawTokenStream+ <*> const True -- | Wrap GHC's 'Severity' to add 'Ord' instance. newtype SeverityOrd = SeverityOrd Severity
− src/Ormolu/Parser/Anns.hs
@@ -1,42 +0,0 @@--- | Ormolu-specific representation of GHC annotations.-module Ormolu.Parser.Anns- ( Anns (..),- emptyAnns,- mkAnns,- lookupAnns,- )-where--import Data.Map.Strict (Map)-import qualified Data.Map.Strict as M-import GHC.Parser.Annotation-import GHC.Parser.Lexer-import GHC.Types.SrcLoc---- | Ormolu-specific representation of GHC annotations.-newtype Anns = Anns (Map RealSrcSpan [AnnKeywordId])- deriving (Eq)---- | Empty 'Anns'.-emptyAnns :: Anns-emptyAnns = Anns M.empty---- | Create 'Anns' from 'PState'.-mkAnns ::- PState ->- Anns-mkAnns pstate =- Anns $- M.fromListWith (++) (f <$> annotations pstate)- where- f ((rspn, kid), _) = (rspn, [kid])---- | Lookup 'AnnKeywordId's corresponding to a given 'SrcSpan'.-lookupAnns ::- -- | Span to lookup with- SrcSpan ->- -- | Collection of annotations- Anns ->- [AnnKeywordId]-lookupAnns (RealSrcSpan rspn _) (Anns m) = M.findWithDefault [] rspn m-lookupAnns (UnhelpfulSpan _) _ = []
src/Ormolu/Parser/CommentStream.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -- | Functions for working with comment stream.@@ -18,6 +19,7 @@ ) where +import Control.Monad ((<=<)) import Data.Char (isSpace) import Data.Data (Data) import Data.Generics.Schemes@@ -32,11 +34,11 @@ import GHC.Hs.Doc import GHC.Hs.Extension import GHC.Hs.ImpExp+import GHC.Parser.Annotation (EpAnnComments (..), getLocA) import qualified GHC.Parser.Annotation as GHC-import qualified GHC.Parser.Lexer as GHC import GHC.Types.SrcLoc import Ormolu.Parser.Pragma-import Ormolu.Utils (onTheSameLine, showOutputable, unSrcSpan)+import Ormolu.Utils (onTheSameLine, showOutputable) ---------------------------------------------------------------------------- -- Comment stream@@ -46,21 +48,19 @@ newtype CommentStream = CommentStream [RealLocated Comment] deriving (Eq, Data, Semigroup, Monoid) --- | Create 'CommentStream' from 'GHC.PState'. The pragmas are+-- | Create 'CommentStream' from 'HsModule'. The pragmas are -- removed from the 'CommentStream'. mkCommentStream :: -- | Original input String ->- -- | Parser state to use for comment extraction- GHC.PState ->- -- | Parsed module+ -- | Module to use for comment extraction HsModule -> -- | Stack header, pragmas, and comment stream ( Maybe (RealLocated Comment), [([RealLocated Comment], Pragma)], CommentStream )-mkCommentStream input pstate hsModule =+mkCommentStream input hsModule = ( mstackHeader, pragmas, CommentStream comments@@ -80,24 +80,25 @@ where -- All comments, including valid and invalid Haddock comments allComments =- fmap (fmap unAnnotationComment)- . (GHC.comment_q <> (concatMap snd . GHC.annotations_comments))- $ pstate+ mapMaybe unAnnotationComment $+ epAnnCommentsToList =<< listify (only @EpAnnComments) hsModule+ where+ epAnnCommentsToList = \case+ EpaComments cs -> cs+ EpaCommentsBalanced pcs fcs -> pcs <> fcs -- All spans of valid Haddock comments -- (everywhere where we use p_hsDoc{String,Name}) validHaddockCommentSpans = S.fromList- . mapMaybe unSrcSpan+ . mapMaybe srcSpanToRealSrcSpan . mconcat [ fmap getLoc . listify (only @LHsDocString),- fmap getLoc . listify (only @LDocDecl),- fmap getLoc . listify isDocD,- fmap getLoc . listify isIEDocLike+ fmap getLocA . listify (only @(LDocDecl GhcPs)),+ fmap getLocA . listify isDocD,+ fmap getLocA . listify isIEDocLike ] $ hsModule where- only :: a -> Bool- only _ = True isDocD :: LHsDecl GhcPs -> Bool isDocD = \case L _ DocD {} -> True@@ -108,6 +109,8 @@ L _ IEDoc {} -> True L _ IEDocNamed {} -> True _ -> False+ only :: a -> Bool+ only _ = True -- | Pretty-print a 'CommentStream'. showCommentStream :: CommentStream -> String@@ -225,22 +228,33 @@ then go' ls' [y'] ys else go' ls [] xs --- | Get a 'String' from 'GHC.AnnotationComment'.-unAnnotationComment :: GHC.AnnotationComment -> String-unAnnotationComment = \case- GHC.AnnDocCommentNext s -> dashPrefix s -- @-- |@- GHC.AnnDocCommentPrev s -> dashPrefix s -- @-- ^@- GHC.AnnDocCommentNamed s -> dashPrefix s -- @-- $@- GHC.AnnDocSection _ s -> dashPrefix s -- @-- *@- GHC.AnnDocOptions s -> s- GHC.AnnLineComment s -> s- GHC.AnnBlockComment s -> s+-- | Extract @'RealLocated' 'String'@ from 'GHC.LEpaComment'.+unAnnotationComment :: GHC.LEpaComment -> Maybe (RealLocated String)+unAnnotationComment (L (GHC.Anchor anchor _) (GHC.EpaComment eck _)) = case eck of+ GHC.EpaDocCommentNext s -> haddock s -- @-- |@+ GHC.EpaDocCommentPrev s -> haddock s -- @-- ^@+ GHC.EpaDocCommentNamed s -> haddock s -- @-- $@+ GHC.EpaDocSection _ s -> haddock s -- @-- *@+ GHC.EpaDocOptions s -> mkL s+ GHC.EpaLineComment s -> mkL $+ case take 3 s of+ "-- " -> s+ "---" -> s+ _ -> let s' = insertAt " " s 3 in s'+ GHC.EpaBlockComment s -> mkL s+ GHC.EpaEofComment -> Nothing where- dashPrefix s = "--" <> spaceIfNecessary <> s+ mkL = Just . L anchor+ insertAt x xs n = take (n - 1) xs ++ x ++ drop (n - 1) xs+ haddock = mkL . dashPrefix <=< dropBlank where- spaceIfNecessary = case s of- c : _ | c /= ' ' -> " "- _ -> ""+ dashPrefix s = "--" <> spaceIfNecessary <> s+ where+ spaceIfNecessary = case s of+ c : _ | c /= ' ' -> " "+ _ -> ""+ dropBlank :: String -> Maybe String+ dropBlank s = if all isSpace s then Nothing else Just s -- | Remove consecutive blank lines. removeConseqBlanks :: NonEmpty String -> NonEmpty String
src/Ormolu/Parser/Pragma.hs view
@@ -16,7 +16,6 @@ import GHC.Data.StringBuffer import qualified GHC.Parser.Lexer as L import GHC.Types.SrcLoc-import GHC.Unit.Module (stringToUnitId) -- | Ormolu's representation of pragmas. data Pragma@@ -67,12 +66,11 @@ where location = mkRealSrcLoc (mkFastString "") 1 1 buffer = stringToStringBuffer input- parseState = L.mkPStatePure parserFlags buffer location- parserFlags =- L.mkParserFlags'+ parseState = L.initParserState parserOpts buffer location+ parserOpts =+ L.mkParserOpts ES.empty ES.empty- (stringToUnitId "") True True True
src/Ormolu/Parser/Result.hs view
@@ -12,7 +12,7 @@ import GHC.Hs import GHC.LanguageExtensions.Type import GHC.Types.SrcLoc-import Ormolu.Parser.Anns+import Ormolu.Config (SourceType) import Ormolu.Parser.CommentStream import Ormolu.Parser.Pragma (Pragma) @@ -21,18 +21,16 @@ -- | A collection of data that represents a parsed module in Ormolu. data ParseResult = ParseResult- { -- | 'ParsedSource' from GHC+ { -- | Parsed module or signature prParsedSource :: HsModule,- -- | Ormolu-specfic representation of annotations- prAnns :: Anns,+ -- | Either regular module or signature file+ prSourceType :: SourceType, -- | Stack header prStackHeader :: Maybe (RealLocated Comment), -- | Pragmas and the associated comments prPragmas :: [([RealLocated Comment], Pragma)], -- | Comment stream prCommentStream :: CommentStream,- -- | Whether or not record dot syntax is enabled- prUseRecordDot :: Bool, -- | Enabled extensions prExtensions :: EnumSet Extension, -- | Indentation level, can be non-zero in case of region formatting
src/Ormolu/Printer.hs view
@@ -4,7 +4,7 @@ -- | Pretty-printer for Haskell AST. module Ormolu.Printer- ( printModule,+ ( printSnippets, ) where @@ -16,13 +16,13 @@ import Ormolu.Printer.SpanStream import Ormolu.Processing.Common --- | Render a module.-printModule ::+-- | Render several source snippets.+printSnippets :: -- | Result of parsing [SourceSnippet] -> -- | Resulting rendition Text-printModule = T.concat . fmap printSnippet+printSnippets = T.concat . fmap printSnippet where printSnippet = \case ParsedSnippet ParseResult {..} ->@@ -35,7 +35,6 @@ ) (mkSpanStream prParsedSource) prCommentStream- prAnns- prUseRecordDot+ prSourceType prExtensions RawSnippet r -> r
src/Ormolu/Printer/Combinators.hs view
@@ -10,7 +10,6 @@ ( -- * The 'R' monad R, runR,- getAnns, getEnclosingSpan, isExtensionEnabled, @@ -26,7 +25,6 @@ inciHalf, located, located',- realLocated, switchLayout, Layout (..), vlayout,@@ -47,7 +45,6 @@ backticks, banana, braces,- recordDotBraces, brackets, parens, parensHash,@@ -74,6 +71,7 @@ import GHC.Types.SrcLoc import Ormolu.Printer.Comments import Ormolu.Printer.Internal+import Ormolu.Utils (HasSrcSpan (..)) ---------------------------------------------------------------------------- -- Basic@@ -87,39 +85,33 @@ R () inciIf b m = if b then inci m else m --- | Enter a 'Located' entity. This combinator handles outputting comments+-- | Enter a 'GenLocated' entity. This combinator handles outputting comments -- and sets layout (single-line vs multi-line) for the inner computation. -- Roughly, the rule for using 'located' is that every time there is a -- 'Located' wrapper, it should be “discharged” with a corresponding -- 'located' invocation. located ::- -- | Thing to enter- Located a ->- -- | How to render inner value- (a -> R ()) ->- R ()-located (L (UnhelpfulSpan _) a) f = f a-located (L (RealSrcSpan l _) a) f = realLocated (L l a) f---- | See 'located'-realLocated ::+ HasSrcSpan l => -- | Thing to enter- RealLocated a ->+ GenLocated l a -> -- | How to render inner value (a -> R ()) -> R ()-realLocated (L l a) f = do- spitPrecedingComments l- withEnclosingSpan l $- switchLayout [RealSrcSpan l Nothing] (f a)- spitFollowingComments l+located (L l' a) f = case loc' l' of+ UnhelpfulSpan _ -> f a+ RealSrcSpan l _ -> do+ spitPrecedingComments l+ withEnclosingSpan l $+ switchLayout [RealSrcSpan l Nothing] (f a)+ spitFollowingComments l -- | A version of 'located' with arguments flipped. located' ::+ HasSrcSpan l => -- | How to render inner value (a -> R ()) -> -- | Thing to enter- Located a ->+ GenLocated l a -> R () located' = flip located @@ -232,23 +224,6 @@ -- | Surround given entity by curly braces @{@ and @}@. braces :: BracketStyle -> R () -> R () braces = brackets_ False "{" "}"---- | Surround record update fields which use RecordDot plugin entity by--- curly braces @{@ and @}@.------ @since 0.1.3.1-recordDotBraces :: R () -> R ()-recordDotBraces m = sitcc (vlayout singleLine multiLine)- where- singleLine = do- txt "{"- m- txt "}"- multiLine = do- txt "{"- sitcc m- newline- txt "}" -- | Surround given entity by square brackets @[@ and @]@. brackets :: BracketStyle -> R () -> R ()
src/Ormolu/Printer/Internal.hs view
@@ -18,7 +18,7 @@ atom, space, newline,- useRecordDot,+ askSourceType, inci, inciHalf, sitcc,@@ -49,9 +49,6 @@ setSpanMark, getSpanMark, - -- * Annotations- getAnns,- -- * Extensions isExtensionEnabled, )@@ -69,10 +66,9 @@ import GHC.Data.EnumSet (EnumSet) import qualified GHC.Data.EnumSet as EnumSet import GHC.LanguageExtensions.Type-import GHC.Parser.Annotation import GHC.Types.SrcLoc import GHC.Utils.Outputable (Outputable)-import Ormolu.Parser.Anns+import Ormolu.Config (SourceType (..)) import Ormolu.Parser.CommentStream import Ormolu.Printer.SpanStream import Ormolu.Utils (showOutputable)@@ -95,14 +91,12 @@ rcLayout :: Layout, -- | Spans of enclosing elements of AST rcEnclosingSpans :: [RealSrcSpan],- -- | Collection of annotations- rcAnns :: Anns, -- | Whether the last expression in the layout can use braces rcCanUseBraces :: Bool,- -- | Whether the source could have used the record dot preprocessor- rcUseRecDot :: Bool, -- | Enabled extensions- rcExtensions :: EnumSet Extension+ rcExtensions :: EnumSet Extension,+ -- | Whether the source is a signature or a regular module+ rcSourceType :: SourceType } -- | State context of 'R'.@@ -166,15 +160,13 @@ SpanStream -> -- | Comment stream CommentStream ->- -- | Annotations- Anns ->- -- | Use Record Dot Syntax- Bool ->+ -- | Whether the source is a signature or a regular module+ SourceType -> -- | Enabled extensions EnumSet Extension -> -- | Resulting rendition Text-runR (R m) sstream cstream anns recDot extensions =+runR (R m) sstream cstream sourceType extensions = TL.toStrict . toLazyText . scBuilder $ execState (runReaderT m rc) sc where rc =@@ -182,10 +174,9 @@ { rcIndent = 0, rcLayout = MultiLine, rcEnclosingSpans = [],- rcAnns = anns, rcCanUseBraces = False,- rcUseRecDot = recDot,- rcExtensions = extensions+ rcExtensions = extensions,+ rcSourceType = sourceType } sc = SC@@ -378,9 +369,9 @@ _ -> AfterNewline } --- | Return 'True' if we should print record dot syntax.-useRecordDot :: R Bool-useRecordDot = R (asks rcUseRecDot)+-- | Return the source type.+askSourceType :: R SourceType+askSourceType = R (asks rcSourceType) inciBy :: Int -> R () -> R () inciBy step (R m) = R (local modRC m)@@ -565,15 +556,6 @@ -- | Get span of last output comment. getSpanMark :: R (Maybe SpanMark) getSpanMark = R (gets scSpanMark)--------------------------------------------------------------------------------- Annotations---- | For a given span return 'AnnKeywordId's associated with it.-getAnns ::- SrcSpan ->- R [AnnKeywordId]-getAnns spn = lookupAnns spn <$> R (asks rcAnns) ---------------------------------------------------------------------------- -- Helpers for braces
src/Ormolu/Printer/Meat/Common.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -- | Rendering of commonly useful bits.@@ -7,7 +8,6 @@ p_hsmodName, p_ieWrappedName, p_rdrName,- doesNotNeedExtraParens, p_qualName, p_infixDefHelper, p_hsDocString,@@ -17,18 +17,18 @@ where import Control.Monad-import Data.List (isPrefixOf) import qualified Data.Text as T import GHC.Hs.Doc import GHC.Hs.ImpExp import GHC.Parser.Annotation-import GHC.Types.Basic-import GHC.Types.Name (nameStableString) import GHC.Types.Name.Occurrence (OccName (..)) import GHC.Types.Name.Reader+import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Unit.Module.Name+import Ormolu.Config (SourceType (..)) import Ormolu.Printer.Combinators+import Ormolu.Printer.Internal (askSourceType) import Ormolu.Utils -- | Data and type family style.@@ -38,78 +38,56 @@ | -- | Top-level declarations Free +-- | Outputs the name of the module-like entity, preceeded by the correct prefix ("module" or "signature"). p_hsmodName :: ModuleName -> R () p_hsmodName mname = do- txt "module"+ sourceType <- askSourceType+ txt $ case sourceType of+ ModuleSource -> "module"+ SignatureSource -> "signature" space atom mname p_ieWrappedName :: IEWrappedName RdrName -> R () p_ieWrappedName = \case IEName x -> p_rdrName x- IEPattern x -> do+ IEPattern _ x -> do txt "pattern" space p_rdrName x- IEType x -> do+ IEType _ x -> do txt "type" space p_rdrName x --- | Render a @'Located' 'RdrName'@.-p_rdrName :: Located RdrName -> R ()-p_rdrName l@(L spn _) = located l $ \x -> do- ids <- getAnns spn- let backticksWrapper =- if AnnBackquote `elem` ids- then backticks- else id- parensWrapper =- if AnnOpenP `elem` ids- then parens N- else id- singleQuoteWrapper =- if AnnSimpleQuote `elem` ids- then \y -> do- txt "'"- y- else id- m =- case x of- Unqual occName ->- atom occName- Qual mname occName ->- p_qualName mname occName- Orig _ occName ->- -- This is used when GHC generates code that will be fed into- -- the renamer (e.g. from deriving clauses), but where we want- -- to say that something comes from given module which is not- -- specified in the source code, e.g. @Prelude.map@.- --- -- My current understanding is that the provided module name- -- serves no purpose for us and can be safely ignored.- atom occName- Exact name ->- atom name- m' = backticksWrapper (singleQuoteWrapper m)- if doesNotNeedExtraParens x- then m'- else parensWrapper m'---- | Whether given name should not have parentheses around it. This is used--- to detect e.g. tuples for which annotations will indicate parentheses,--- but the parentheses are already part of the symbol, so no extra layer of--- parentheses should be added. It also detects the [] literal.-doesNotNeedExtraParens :: RdrName -> Bool-doesNotNeedExtraParens = \case- Exact name ->- let s = nameStableString name- in -- I'm not sure this "stable string" is stable enough, but it looks- -- like this is the most robust way to tell if we're looking at- -- exactly this piece of built-in syntax.- ("$ghc-prim$GHC.Tuple$" `isPrefixOf` s)- || ("$ghc-prim$GHC.Types$[]" `isPrefixOf` s)- _ -> False+-- | Render a @'LocatedN' 'RdrName'@.+p_rdrName :: LocatedN RdrName -> R ()+p_rdrName l = located l $ \x -> do+ let wrapper = \case+ EpAnn {anns} -> case anns of+ NameAnnQuote {nann_quoted} -> tickPrefix . wrapper (ann nann_quoted)+ NameAnn {nann_adornment = NameParens} -> parens N+ NameAnn {nann_adornment = NameBackquotes} -> backticks+ _ -> id+ EpAnnNotUsed -> id+ wrapper (ann . getLoc $ l) $ case x of+ Unqual occName ->+ atom occName+ Qual mname occName ->+ p_qualName mname occName+ Orig _ occName ->+ -- This is used when GHC generates code that will be fed into+ -- the renamer (e.g. from deriving clauses), but where we want+ -- to say that something comes from given module which is not+ -- specified in the source code, e.g. @Prelude.map@.+ --+ -- My current understanding is that the provided module name+ -- serves no purpose for us and can be safely ignored.+ atom occName+ Exact name ->+ atom name+ where+ tickPrefix y = txt "'" *> y p_qualName :: ModuleName -> OccName -> R () p_qualName mname occName = do
src/Ormolu/Printer/Meat/Declaration.hs view
@@ -14,14 +14,13 @@ import Data.List (sort) import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as NE-import GHC.Hs.Binds-import GHC.Hs.Decls-import GHC.Hs.Extension-import GHC.Hs.Pat+import GHC.Hs import GHC.Types.Name.Occurrence (occNameFS) import GHC.Types.Name.Reader import GHC.Types.SrcLoc+import Ormolu.Config (SourceType (SignatureSource)) import Ormolu.Printer.Combinators+import Ormolu.Printer.Internal (askSourceType) import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Declaration.Annotation import Ormolu.Printer.Meat.Declaration.Class@@ -59,11 +58,12 @@ p_hsDeclsRespectGrouping = p_hsDecls' Respect p_hsDecls' :: UserGrouping -> FamilyStyle -> [LHsDecl GhcPs] -> R ()-p_hsDecls' grouping style decls =+p_hsDecls' grouping style decls = do+ isSig <- (== SignatureSource) <$> askSourceType sepSemi id $ -- Return a list of rendered declarations, adding a newline to separate -- groups.- case groupDecls decls of+ case groupDecls isSig decls of [] -> [] (x : xs) -> renderGroup x ++ concat (zipWith renderGroupWithPrev (x : xs) xs) where@@ -75,7 +75,7 @@ Disregard -> breakpoint : renderGroup curr Respect ->- if separatedByBlankNE getLoc prev curr+ if separatedByBlankNE getLocA prev curr || isDocumented prev || isDocumented curr then breakpoint : renderGroup curr@@ -90,47 +90,52 @@ isHaddock _ = False -- | Group relevant declarations together.-groupDecls :: [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)]-groupDecls [] = []-groupDecls (l@(L _ DocNext) : xs) =+groupDecls ::+ -- | Is the source a signature file?+ Bool ->+ -- | List of declarations+ [LHsDecl GhcPs] ->+ [NonEmpty (LHsDecl GhcPs)]+groupDecls _ [] = []+groupDecls isSig (l@(L _ DocNext) : xs) = -- If the first element is a doc string for next element, just include it -- in the next block:- case groupDecls xs of+ case groupDecls isSig xs of [] -> [l :| []] (x : xs') -> (l <| x) : xs'-groupDecls (header : xs) =+groupDecls isSig (header : xs) = let (grp, rest) = flip span (zip (header : xs) xs) $ \(previous, current) -> let relevantToHdr = groupedDecls header current relevantToPrev = groupedDecls previous current- isDeclSeries = declSeries previous current+ isDeclSeries = not isSig && declSeries previous current in isDeclSeries || relevantToHdr || relevantToPrev- in (header :| map snd grp) : groupDecls (map snd rest)+ in (header :| map snd grp) : groupDecls isSig (map snd rest) p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R () p_hsDecl style = \case- TyClD NoExtField x -> p_tyClDecl style x- ValD NoExtField x -> p_valDecl x- SigD NoExtField x -> p_sigDecl x- InstD NoExtField x -> p_instDecl style x- DerivD NoExtField x -> p_standaloneDerivDecl x- DefD NoExtField x -> p_defaultDecl x- ForD NoExtField x -> p_foreignDecl x- WarningD NoExtField x -> p_warnDecls x- AnnD NoExtField x -> p_annDecl x- RuleD NoExtField x -> p_ruleDecls x- SpliceD NoExtField x -> p_spliceDecl x- DocD NoExtField docDecl ->+ TyClD _ x -> p_tyClDecl style x+ ValD _ x -> p_valDecl x+ SigD _ x -> p_sigDecl x+ InstD _ x -> p_instDecl style x+ DerivD _ x -> p_standaloneDerivDecl x+ DefD _ x -> p_defaultDecl x+ ForD _ x -> p_foreignDecl x+ WarningD _ x -> p_warnDecls x+ AnnD _ x -> p_annDecl x+ RuleD _ x -> p_ruleDecls x+ SpliceD _ x -> p_spliceDecl x+ DocD _ docDecl -> case docDecl of DocCommentNext str -> p_hsDocString Pipe False (noLoc str) DocCommentPrev str -> p_hsDocString Caret False (noLoc str) DocCommentNamed name str -> p_hsDocString (Named name) False (noLoc str) DocGroup n str -> p_hsDocString (Asterisk n) False (noLoc str)- RoleAnnotD NoExtField x -> p_roleAnnot x- KindSigD NoExtField s -> p_standaloneKindSig s+ RoleAnnotD _ x -> p_roleAnnot x+ KindSigD _ s -> p_standaloneKindSig s p_tyClDecl :: FamilyStyle -> TyClDecl GhcPs -> R () p_tyClDecl style = \case- FamDecl NoExtField x -> p_famDecl style x+ FamDecl _ x -> p_famDecl style x SynDecl {..} -> p_synDecl tcdLName tcdFixity tcdTyVars tcdRhs DataDecl {..} -> p_dataDecl@@ -154,16 +159,16 @@ p_instDecl :: FamilyStyle -> InstDecl GhcPs -> R () p_instDecl style = \case- ClsInstD NoExtField x -> p_clsInstDecl x- TyFamInstD NoExtField x -> p_tyFamInstDecl style x- DataFamInstD NoExtField x -> p_dataFamInstDecl style x+ ClsInstD _ x -> p_clsInstDecl x+ TyFamInstD _ x -> p_tyFamInstDecl style x+ DataFamInstD _ x -> p_dataFamInstDecl style x -- | Determine if these declarations should be grouped together. groupedDecls :: LHsDecl GhcPs -> LHsDecl GhcPs -> Bool-groupedDecls (L l_x x') (L l_y y') =+groupedDecls (L (locA -> l_x) x') (L (locA -> l_y) y') = case (x', y') of (TypeSignature ns, FunctionBody ns') -> ns `intersects` ns' (TypeSignature ns, DefaultSignature ns') -> ns `intersects` ns'@@ -174,11 +179,11 @@ (x, DataDeclaration n) | Just ns <- isPragma x -> n `elem` ns (DataDeclaration n, x) | Just ns <- isPragma x ->- let f = occNameFS . rdrNameOcc in f n `elem` map f ns+ let f = occNameFS . rdrNameOcc in f n `elem` map f ns (x, y) | Just ns <- isPragma x, Just ns' <- isPragma y ->- ns `intersects` ns'+ ns `intersects` ns' (x, TypeSignature ns) | Just ns' <- isPragma x -> ns `intersects` ns' (TypeSignature ns, x) | Just ns' <- isPragma x -> ns `intersects` ns' (PatternSignature ns, Pattern n) -> n `elem` ns@@ -200,8 +205,8 @@ Bool declSeries (L _ x) (L _ y) = case (x, y) of- ( SigD NoExtField (TypeSig NoExtField _ _),- SigD NoExtField (TypeSig NoExtField _ _)+ ( SigD _ (TypeSig _ _ _),+ SigD _ (TypeSig _ _ _) ) -> True _ -> False @@ -231,7 +236,7 @@ -- Declarations that do not refer to names pattern Splice :: HsDecl GhcPs-pattern Splice <- SpliceD NoExtField (SpliceDecl NoExtField _ _)+pattern Splice <- SpliceD _ (SpliceDecl _ _ _) -- Declarations referring to a single name @@ -248,17 +253,17 @@ FamilyDeclaration, TypeSynonym :: RdrName -> HsDecl GhcPs-pattern InlinePragma n <- SigD NoExtField (InlineSig NoExtField (L _ n) _)-pattern SpecializePragma n <- SigD NoExtField (SpecSig NoExtField (L _ n) _ _)-pattern SCCPragma n <- SigD NoExtField (SCCFunSig NoExtField _ (L _ n) _)-pattern AnnTypePragma n <- AnnD NoExtField (HsAnnotation NoExtField _ (TypeAnnProvenance (L _ n)) _)-pattern AnnValuePragma n <- AnnD NoExtField (HsAnnotation NoExtField _ (ValueAnnProvenance (L _ n)) _)-pattern Pattern n <- ValD NoExtField (PatSynBind NoExtField (PSB _ (L _ n) _ _ _))-pattern DataDeclaration n <- TyClD NoExtField (DataDecl NoExtField (L _ n) _ _ _)-pattern ClassDeclaration n <- TyClD NoExtField (ClassDecl _ _ (L _ n) _ _ _ _ _ _ _ _)-pattern KindSignature n <- KindSigD NoExtField (StandaloneKindSig NoExtField (L _ n) _)-pattern FamilyDeclaration n <- TyClD NoExtField (FamDecl NoExtField (FamilyDecl NoExtField _ (L _ n) _ _ _ _))-pattern TypeSynonym n <- TyClD NoExtField (SynDecl NoExtField (L _ n) _ _ _)+pattern InlinePragma n <- SigD _ (InlineSig _ (L _ n) _)+pattern SpecializePragma n <- SigD _ (SpecSig _ (L _ n) _ _)+pattern SCCPragma n <- SigD _ (SCCFunSig _ _ (L _ n) _)+pattern AnnTypePragma n <- AnnD _ (HsAnnotation _ _ (TypeAnnProvenance (L _ n)) _)+pattern AnnValuePragma n <- AnnD _ (HsAnnotation _ _ (ValueAnnProvenance (L _ n)) _)+pattern Pattern n <- ValD _ (PatSynBind _ (PSB _ (L _ n) _ _ _))+pattern DataDeclaration n <- TyClD _ (DataDecl _ (L _ n) _ _ _)+pattern ClassDeclaration n <- TyClD _ (ClassDecl _ _ (L _ n) _ _ _ _ _ _ _ _)+pattern KindSignature n <- KindSigD _ (StandaloneKindSig _ (L _ n) _)+pattern FamilyDeclaration n <- TyClD _ (FamDecl _ (FamilyDecl _ _ _ (L _ n) _ _ _ _))+pattern TypeSynonym n <- TyClD _ (SynDecl _ (L _ n) _ _ _) -- Declarations which can refer to multiple names @@ -276,47 +281,47 @@ pattern WarningPragma n <- (warnSigRdrNames -> Just n) pattern DocNext, DocPrev :: HsDecl GhcPs-pattern DocNext <- (DocD NoExtField (DocCommentNext _))-pattern DocPrev <- (DocD NoExtField (DocCommentPrev _))+pattern DocNext <- (DocD _ (DocCommentNext _))+pattern DocPrev <- (DocD _ (DocCommentPrev _)) sigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]-sigRdrNames (SigD NoExtField (TypeSig NoExtField ns _)) = Just $ map unLoc ns-sigRdrNames (SigD NoExtField (ClassOpSig NoExtField _ ns _)) = Just $ map unLoc ns-sigRdrNames (SigD NoExtField (PatSynSig NoExtField ns _)) = Just $ map unLoc ns+sigRdrNames (SigD _ (TypeSig _ ns _)) = Just $ map unLoc ns+sigRdrNames (SigD _ (ClassOpSig _ _ ns _)) = Just $ map unLoc ns+sigRdrNames (SigD _ (PatSynSig _ ns _)) = Just $ map unLoc ns sigRdrNames _ = Nothing defSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]-defSigRdrNames (SigD NoExtField (ClassOpSig NoExtField True ns _)) = Just $ map unLoc ns+defSigRdrNames (SigD _ (ClassOpSig _ True ns _)) = Just $ map unLoc ns defSigRdrNames _ = Nothing funRdrNames :: HsDecl GhcPs -> Maybe [RdrName]-funRdrNames (ValD NoExtField (FunBind NoExtField (L _ n) _ _)) = Just [n]-funRdrNames (ValD NoExtField (PatBind NoExtField (L _ n) _ _)) = Just $ patBindNames n+funRdrNames (ValD _ (FunBind _ (L _ n) _ _)) = Just [n]+funRdrNames (ValD _ (PatBind _ (L _ n) _ _)) = Just $ patBindNames n funRdrNames _ = Nothing patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]-patSigRdrNames (SigD NoExtField (PatSynSig NoExtField ns _)) = Just $ map unLoc ns+patSigRdrNames (SigD _ (PatSynSig _ ns _)) = Just $ map unLoc ns patSigRdrNames _ = Nothing warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]-warnSigRdrNames (WarningD NoExtField (Warnings NoExtField _ ws)) = Just $- flip concatMap ws $ \(L _ (Warning NoExtField ns _)) -> map unLoc ns+warnSigRdrNames (WarningD _ (Warnings _ _ ws)) = Just $+ flip concatMap ws $ \(L _ (Warning _ ns _)) -> map unLoc ns warnSigRdrNames _ = Nothing patBindNames :: Pat GhcPs -> [RdrName]-patBindNames (TuplePat NoExtField ps _) = concatMap (patBindNames . unLoc) ps-patBindNames (VarPat NoExtField (L _ n)) = [n]-patBindNames (WildPat NoExtField) = []-patBindNames (LazyPat NoExtField (L _ p)) = patBindNames p-patBindNames (BangPat NoExtField (L _ p)) = patBindNames p-patBindNames (ParPat NoExtField (L _ p)) = patBindNames p-patBindNames (ListPat NoExtField ps) = concatMap (patBindNames . unLoc) ps-patBindNames (AsPat NoExtField (L _ n) (L _ p)) = n : patBindNames p-patBindNames (SumPat NoExtField (L _ p) _ _) = patBindNames p-patBindNames (ViewPat NoExtField _ (L _ p)) = patBindNames p-patBindNames (SplicePat NoExtField _) = []-patBindNames (LitPat NoExtField _) = []+patBindNames (TuplePat _ ps _) = concatMap (patBindNames . unLoc) ps+patBindNames (VarPat _ (L _ n)) = [n]+patBindNames (WildPat _) = []+patBindNames (LazyPat _ (L _ p)) = patBindNames p+patBindNames (BangPat _ (L _ p)) = patBindNames p+patBindNames (ParPat _ (L _ p)) = patBindNames p+patBindNames (ListPat _ ps) = concatMap (patBindNames . unLoc) ps+patBindNames (AsPat _ (L _ n) (L _ p)) = n : patBindNames p+patBindNames (SumPat _ (L _ p) _ _) = patBindNames p+patBindNames (ViewPat _ _ (L _ p)) = patBindNames p+patBindNames (SplicePat _ _) = []+patBindNames (LitPat _ _) = [] patBindNames (SigPat _ (L _ p) _) = patBindNames p-patBindNames (NPat NoExtField _ _ _) = []-patBindNames (NPlusKPat NoExtField (L _ n) _ _ _ _) = [n]-patBindNames (ConPat NoExtField _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d)+patBindNames (NPat _ _ _ _) = []+patBindNames (NPlusKPat _ (L _ n) _ _ _ _) = [n]+patBindNames (ConPat _ _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d)
src/Ormolu/Printer/Meat/Declaration/Annotation.hs view
@@ -6,20 +6,19 @@ ) where -import GHC.Hs.Decls-import GHC.Hs.Extension+import GHC.Hs import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Declaration.Value p_annDecl :: AnnDecl GhcPs -> R ()-p_annDecl (HsAnnotation NoExtField _ annProv expr) =+p_annDecl (HsAnnotation _ _ annProv expr) = pragma "ANN" . inci $ do p_annProv annProv breakpoint located expr p_hsExpr -p_annProv :: AnnProvenance (IdP GhcPs) -> R ()+p_annProv :: AnnProvenance GhcPs -> R () p_annProv = \case ValueAnnProvenance name -> p_rdrName name TypeAnnProvenance name -> txt "type" >> space >> p_rdrName name
src/Ormolu/Printer/Meat/Declaration/Class.hs view
@@ -13,12 +13,9 @@ import Data.Foldable import Data.Function (on) import Data.List (sortBy)-import GHC.Core.Class-import GHC.Hs.Binds-import GHC.Hs.Decls-import GHC.Hs.Extension-import GHC.Hs.Type-import GHC.Types.Basic+import Data.Maybe+import GHC.Hs+import GHC.Types.Fixity import GHC.Types.Name.Reader import GHC.Types.SrcLoc import Ormolu.Printer.Combinators@@ -27,32 +24,32 @@ import Ormolu.Printer.Meat.Type p_classDecl ::- LHsContext GhcPs ->- Located RdrName ->+ Maybe (LHsContext GhcPs) ->+ LocatedN RdrName -> LHsQTyVars GhcPs -> LexicalFixity ->- [Located (FunDep (Located RdrName))] ->+ [LHsFunDep GhcPs] -> [LSig GhcPs] -> LHsBinds GhcPs -> [LFamilyDecl GhcPs] -> [LTyFamDefltDecl GhcPs] ->- [LDocDecl] ->+ [LDocDecl GhcPs] -> R () p_classDecl ctx name HsQTvs {..} fixity fdeps csigs cdefs cats catdefs cdocs = do- let variableSpans = getLoc <$> hsq_explicit- signatureSpans = getLoc name : variableSpans- dependencySpans = getLoc <$> fdeps- combinedSpans = getLoc ctx : (signatureSpans ++ dependencySpans)+ let variableSpans = getLocA <$> hsq_explicit+ signatureSpans = getLocA name : variableSpans+ dependencySpans = getLocA <$> fdeps+ combinedSpans = maybeToList (getLocA <$> ctx) ++ signatureSpans ++ dependencySpans -- GHC's AST does not necessarily store each kind of element in source -- location order. This happens because different declarations are stored -- in different lists. Consequently, to get all the declarations in proper -- order, they need to be manually sorted.- sigs = (getLoc &&& fmap (SigD NoExtField)) <$> csigs- vals = (getLoc &&& fmap (ValD NoExtField)) <$> toList cdefs- tyFams = (getLoc &&& fmap (TyClD NoExtField . FamDecl NoExtField)) <$> cats- docs = (getLoc &&& fmap (DocD NoExtField)) <$> cdocs+ sigs = (getLocA &&& fmap (SigD NoExtField)) <$> csigs+ vals = (getLocA &&& fmap (ValD NoExtField)) <$> toList cdefs+ tyFams = (getLocA &&& fmap (TyClD NoExtField . FamDecl NoExtField)) <$> cats+ docs = (getLocA &&& fmap (DocD NoExtField)) <$> cdocs tyFamDefs =- ( getLoc &&& fmap (InstD NoExtField . TyFamInstD NoExtField)+ ( getLocA &&& fmap (InstD NoExtField . TyFamInstD NoExtField) ) <$> catdefs allDecls =@@ -61,7 +58,7 @@ switchLayout combinedSpans $ do breakpoint inci $ do- p_classContext ctx+ for_ ctx p_classContext switchLayout signatureSpans $ p_infixDefHelper (isInfix fixity)@@ -83,15 +80,15 @@ txt "=>" breakpoint -p_classFundeps :: [Located (FunDep (Located RdrName))] -> R ()+p_classFundeps :: [LHsFunDep GhcPs] -> R () p_classFundeps fdeps = unless (null fdeps) $ do breakpoint txt "|" space inci $ sep commaDel (sitcc . located' p_funDep) fdeps -p_funDep :: FunDep (Located RdrName) -> R ()-p_funDep (before, after) = do+p_funDep :: FunDep GhcPs -> R ()+p_funDep (FunDep _ before after) = do sep space p_rdrName before space txt "->"
src/Ormolu/Printer/Meat/Declaration/Data.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BlockArguments #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}@@ -11,24 +12,21 @@ import Control.Monad import Data.Maybe (isJust, maybeToList)-import GHC.Hs.Decls-import GHC.Hs.Extension-import GHC.Hs.Type-import GHC.Parser.Annotation-import GHC.Types.Basic+import Data.Void+import GHC.Hs+import GHC.Types.Fixity import GHC.Types.ForeignCall import GHC.Types.Name.Reader import GHC.Types.SrcLoc import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Type-import Ormolu.Utils p_dataDecl :: -- | Whether to format as data family FamilyStyle -> -- | Type constructor- Located RdrName ->+ LocatedN RdrName -> -- | Type patterns HsTyPats GhcPs -> -- | Lexical fixity@@ -52,8 +50,8 @@ Just (Header h _) -> space *> p_sourceText h p_sourceText type_ txt " #-}"- let constructorSpans = getLoc name : fmap lhsTypeArgSrcSpan tpats- sigSpans = maybeToList . fmap getLoc $ dd_kindSig+ let constructorSpans = getLocA name : fmap lhsTypeArgSrcSpan tpats+ sigSpans = maybeToList . fmap getLocA $ dd_kindSig declHeaderSpans = constructorSpans ++ sigSpans switchLayout declHeaderSpans $ do breakpoint@@ -78,7 +76,7 @@ txt "where" breakpoint sepSemi (located' (p_conDecl False)) dd_cons- else switchLayout (getLoc name : (getLoc <$> dd_cons)) . inci $ do+ else switchLayout (getLocA name : (getLocA <$> dd_cons)) . inci $ do let singleConstRec = isSingleConstRec dd_cons if singleConstRec then space@@ -98,9 +96,8 @@ then id else sitcc sep s (sitcc' . located' (p_conDecl singleConstRec)) dd_cons- unless (null $ unLoc dd_derivs) breakpoint- inci . located dd_derivs $ \xs ->- sep newline (located' p_hsDerivingClause) xs+ unless (null dd_derivs) breakpoint+ inci $ sep newline (located' p_hsDerivingClause) dd_derivs p_conDecl :: Bool ->@@ -110,11 +107,14 @@ ConDeclGADT {..} -> do mapM_ (p_hsDocString Pipe True) con_doc let conDeclSpn =- fmap getLoc con_names- <> [getLoc con_forall]- <> fmap getLoc con_qvars- <> maybeToList (fmap getLoc con_mb_cxt)- <> conArgsSpans con_args+ fmap getLocA con_names+ <> [getLocA con_bndrs]+ <> maybeToList (fmap getLocA con_mb_cxt)+ <> conArgsSpans+ where+ conArgsSpans = case con_g_args of+ PrefixConGADT xs -> getLocA . hsScaledThing <$> xs+ RecConGADT x -> [getLocA x] switchLayout conDeclSpn $ do case con_names of [] -> return ()@@ -131,50 +131,51 @@ then newline else breakpoint interArgBreak- conTy <- case con_args of- PrefixCon xs ->- let go (HsScaled a b) t = L (combineLocs t b) (HsFunTy NoExtField a b t)- in pure $ foldr go con_res_ty xs- RecCon r@(L l rs) ->- pure- . L (combineLocs r con_res_ty)- $ HsFunTy- NoExtField- (HsUnrestrictedArrow NormalSyntax)- (L l $ HsRecTy NoExtField rs)- con_res_ty- InfixCon _ _ -> notImplemented "InfixCon" -- NOTE(amesgen) should be unreachable- let qualTy = case con_mb_cxt of+ let conTy = case con_g_args of+ PrefixConGADT xs ->+ let go (HsScaled a b) t = addCLocAA t b (HsFunTy EpAnnNotUsed a b t)+ in foldr go con_res_ty xs+ RecConGADT r ->+ addCLocAA r con_res_ty $+ HsFunTy+ EpAnnNotUsed+ (HsUnrestrictedArrow NormalSyntax)+ (la2la $ HsRecTy EpAnnNotUsed <$> r)+ con_res_ty+ qualTy = case con_mb_cxt of Nothing -> conTy Just qs ->- L (combineLocs qs conTy) $- HsQualTy NoExtField qs conTy- let quantifiedTy =- if unLoc con_forall- then- L (combineLocs con_forall qualTy) $- HsForAllTy NoExtField (mkHsForAllInvisTele con_qvars) qualTy- else qualTy+ addCLocAA qs conTy $+ HsQualTy NoExtField (Just qs) conTy+ quantifiedTy =+ addCLocAA con_bndrs qualTy $+ hsOuterTyVarBndrsToHsType (unLoc con_bndrs) qualTy p_hsType (unLoc quantifiedTy) ConDeclH98 {..} -> do mapM_ (p_hsDocString Pipe True) con_doc let conDeclWithContextSpn =- [getLoc con_forall]- <> fmap getLoc con_ex_tvs- <> maybeToList (fmap getLoc con_mb_cxt)+ [RealSrcSpan real Nothing | AddEpAnn AnnForall (EpaSpan real) <- epAnnAnns con_ext]+ <> fmap getLocA con_ex_tvs+ <> maybeToList (fmap getLocA con_mb_cxt) <> conDeclSpn- conDeclSpn =- getLoc con_name : conArgsSpans con_args+ conDeclSpn = getLocA con_name : conArgsSpans+ where+ conArgsSpans = case con_args of+ PrefixCon [] xs -> getLocA . hsScaledThing <$> xs+ PrefixCon (v : _) _ -> absurd v+ RecCon l -> [getLocA l]+ InfixCon x y -> getLocA . hsScaledThing <$> [x, y] switchLayout conDeclWithContextSpn $ do- when (unLoc con_forall) $ do+ when con_forall $ do p_forallBndrs ForAllInvis p_hsTyVarBndr con_ex_tvs breakpoint forM_ con_mb_cxt p_lhsContext switchLayout conDeclSpn $ case con_args of- PrefixCon xs -> do+ PrefixCon [] xs -> do p_rdrName con_name unless (null xs) breakpoint inci . sitcc $ sep breakpoint (sitcc . located' p_hsTypePostDoc) (hsScaledThing <$> xs)+ PrefixCon (v : _) _ -> absurd v RecCon l -> do p_rdrName con_name breakpoint@@ -187,15 +188,6 @@ space located y p_hsType -conArgsSpans :: HsConDeclDetails GhcPs -> [SrcSpan]-conArgsSpans = \case- PrefixCon xs ->- getLoc . hsScaledThing <$> xs- RecCon l ->- [getLoc l]- InfixCon x y ->- getLoc . hsScaledThing <$> [x, y]- p_lhsContext :: LHsContext GhcPs -> R ()@@ -218,39 +210,39 @@ p_hsDerivingClause HsDerivingClause {..} = do txt "deriving" let derivingWhat = located deriv_clause_tys $ \case- [] -> txt "()"- xs ->+ DctSingle NoExtField sigTy -> parens N $ located sigTy p_hsSigType+ DctMulti NoExtField sigTys -> parens N $ sep commaDel- (sitcc . located' p_hsType . hsib_body)- xs+ (sitcc . located' p_hsSigType)+ sigTys space case deriv_clause_strategy of Nothing -> do breakpoint inci derivingWhat Just (L _ a) -> case a of- StockStrategy -> do+ StockStrategy _ -> do txt "stock" breakpoint inci derivingWhat- AnyclassStrategy -> do+ AnyclassStrategy _ -> do txt "anyclass" breakpoint inci derivingWhat- NewtypeStrategy -> do+ NewtypeStrategy _ -> do txt "newtype" breakpoint inci derivingWhat- ViaStrategy HsIB {..} -> do+ ViaStrategy (XViaStrategyPs _ sigTy) -> do breakpoint inci $ do derivingWhat breakpoint txt "via" space- located hsib_body p_hsType+ located sigTy p_hsSigType ---------------------------------------------------------------------------- -- Helpers
src/Ormolu/Printer/Meat/Declaration/Default.hs view
@@ -6,13 +6,12 @@ ) where -import GHC.Hs.Decls-import GHC.Hs.Extension+import GHC.Hs import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Type p_defaultDecl :: DefaultDecl GhcPs -> R ()-p_defaultDecl (DefaultDecl NoExtField ts) = do+p_defaultDecl (DefaultDecl _ ts) = do txt "default" breakpoint inci . parens N $
src/Ormolu/Printer/Meat/Declaration/Foreign.hs view
@@ -8,9 +8,7 @@ where import Control.Monad-import GHC.Hs.Decls-import GHC.Hs.Extension-import GHC.Hs.Type+import GHC.Hs import GHC.Types.ForeignCall import GHC.Types.SrcLoc import Ormolu.Printer.Combinators@@ -33,12 +31,12 @@ breakpoint inci . switchLayout- [ getLoc (fd_name fd),- (getLoc . hsib_body . fd_sig_ty) fd+ [ getLocA (fd_name fd),+ (getLocA . fd_sig_ty) fd ] $ do p_rdrName (fd_name fd)- p_typeAscription (HsWC NoExtField (fd_sig_ty fd))+ p_typeAscription (fd_sig_ty fd) -- | Printer for 'ForeignImport'. --
src/Ormolu/Printer/Meat/Declaration/Instance.hs view
@@ -16,9 +16,7 @@ import Data.Foldable import Data.Function (on) import Data.List (sortBy)-import GHC.Hs.Decls-import GHC.Hs.Extension-import GHC.Hs.Type+import GHC.Hs import GHC.Types.Basic import GHC.Types.SrcLoc import Ormolu.Printer.Combinators@@ -30,7 +28,7 @@ p_standaloneDerivDecl :: DerivDecl GhcPs -> R () p_standaloneDerivDecl DerivDecl {..} = do- let typesAfterInstance = located (hsib_body (hswc_body deriv_type)) p_hsType+ let typesAfterInstance = located (hswc_body deriv_type) p_hsSigType instTypes toIndent = inci $ do txt "instance" breakpoint@@ -42,47 +40,46 @@ Nothing -> instTypes False Just (L _ a) -> case a of- StockStrategy -> do+ StockStrategy _ -> do txt "stock " instTypes False- AnyclassStrategy -> do+ AnyclassStrategy _ -> do txt "anyclass " instTypes False- NewtypeStrategy -> do+ NewtypeStrategy _ -> do txt "newtype " instTypes False- ViaStrategy HsIB {..} -> do+ ViaStrategy (XViaStrategyPs _ sigTy) -> do txt "via" breakpoint- inci (located hsib_body p_hsType)+ inci (located sigTy p_hsSigType) breakpoint instTypes True p_clsInstDecl :: ClsInstDecl GhcPs -> R () p_clsInstDecl ClsInstDecl {..} = do txt "instance"- let HsIB {..} = cid_poly_ty -- GHC's AST does not necessarily store each kind of element in source -- location order. This happens because different declarations are stored in -- different lists. Consequently, to get all the declarations in proper -- order, they need to be manually sorted.- let sigs = (getLoc &&& fmap (SigD NoExtField)) <$> cid_sigs- vals = (getLoc &&& fmap (ValD NoExtField)) <$> toList cid_binds+ let sigs = (getLocA &&& fmap (SigD NoExtField)) <$> cid_sigs+ vals = (getLocA &&& fmap (ValD NoExtField)) <$> toList cid_binds tyFamInsts =- ( getLoc &&& fmap (InstD NoExtField . TyFamInstD NoExtField)+ ( getLocA &&& fmap (InstD NoExtField . TyFamInstD NoExtField) ) <$> cid_tyfam_insts dataFamInsts =- ( getLoc &&& fmap (InstD NoExtField . DataFamInstD NoExtField)+ ( getLocA &&& fmap (InstD NoExtField . DataFamInstD EpAnnNotUsed) ) <$> cid_datafam_insts allDecls = snd <$> sortBy (leftmost_smallest `on` fst) (sigs <> vals <> tyFamInsts <> dataFamInsts)- located hsib_body $ \x -> do+ located cid_poly_ty $ \sigTy -> do breakpoint inci $ do match_overlap_mode cid_overlap_mode breakpoint- p_hsType x+ p_hsSigType sigTy unless (null allDecls) $ do breakpoint txt "where"@@ -100,10 +97,10 @@ inci (p_tyFamInstEqn tfid_eqn) p_dataFamInstDecl :: FamilyStyle -> DataFamInstDecl GhcPs -> R ()-p_dataFamInstDecl style (DataFamInstDecl {dfid_eqn = HsIB {hsib_body = FamEqn {..}}}) =+p_dataFamInstDecl style (DataFamInstDecl {dfid_eqn = FamEqn {..}}) = p_dataDecl style feqn_tycon feqn_pats feqn_fixity feqn_rhs -match_overlap_mode :: Maybe (Located OverlapMode) -> R () -> R ()+match_overlap_mode :: Maybe (LocatedP OverlapMode) -> R () -> R () match_overlap_mode overlap_mode layoutStrategy = case unLoc <$> overlap_mode of Just Overlappable {} -> do
src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs view
@@ -9,17 +9,16 @@ where import GHC.Core.Coercion.Axiom-import GHC.Hs.Decls-import GHC.Hs.Extension+import GHC.Hs hiding (anns) import GHC.Types.Name.Reader import GHC.Types.SrcLoc import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common p_roleAnnot :: RoleAnnotDecl GhcPs -> R ()-p_roleAnnot (RoleAnnotDecl NoExtField l_name anns) = p_roleAnnot' l_name anns+p_roleAnnot (RoleAnnotDecl _ l_name anns) = p_roleAnnot' l_name anns -p_roleAnnot' :: Located RdrName -> [Located (Maybe Role)] -> R ()+p_roleAnnot' :: LocatedN RdrName -> [Located (Maybe Role)] -> R () p_roleAnnot' l_name anns = do txt "type role" breakpoint
src/Ormolu/Printer/Meat/Declaration/Rule.hs view
@@ -8,11 +8,9 @@ where import Control.Monad (unless)-import GHC.Hs.Decls-import GHC.Hs.Extension-import GHC.Hs.Lit-import GHC.Hs.Type+import GHC.Hs import GHC.Types.Basic+import GHC.Types.SourceText import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Declaration.Signature@@ -20,11 +18,11 @@ import Ormolu.Printer.Meat.Type p_ruleDecls :: RuleDecls GhcPs -> R ()-p_ruleDecls (HsRules NoExtField _ xs) =+p_ruleDecls (HsRules _ _ xs) = pragma "RULES" $ sep breakpoint (sitcc . located' p_ruleDecl) xs p_ruleDecl :: RuleDecl GhcPs -> R ()-p_ruleDecl (HsRule NoExtField ruleName activation tyvars ruleBndrs lhs rhs) = do+p_ruleDecl (HsRule _ ruleName activation tyvars ruleBndrs lhs rhs) = do located ruleName p_ruleName space p_activation activation@@ -38,7 +36,7 @@ -- in the input or no forall at all. We do not want to add redundant -- foralls, so let's just skip the empty ones. unless (null ruleBndrs) $- p_forallBndrs ForAllInvis p_ruleBndr ruleBndrs+ p_forallBndrs ForAllInvis p_ruleBndr (reLocA <$> ruleBndrs) breakpoint inci $ do located lhs p_hsExpr@@ -53,7 +51,7 @@ p_ruleBndr :: RuleBndr GhcPs -> R () p_ruleBndr = \case- RuleBndr NoExtField x -> p_rdrName x- RuleBndrSig NoExtField x HsPS {..} -> parens N $ do+ RuleBndr _ x -> p_rdrName x+ RuleBndrSig _ x HsPS {..} -> parens N $ do p_rdrName x- p_typeAscription (HsWC NoExtField (HsIB NoExtField hsps_body))+ p_typeAscription (lhsTypeToSigType hsps_body)
src/Ormolu/Printer/Meat/Declaration/Signature.hs view
@@ -13,12 +13,11 @@ import Control.Monad import GHC.Data.BooleanFormula-import GHC.Hs.Binds-import GHC.Hs.Decls-import GHC.Hs.Extension-import GHC.Hs.Type+import GHC.Hs import GHC.Types.Basic+import GHC.Types.Fixity import GHC.Types.Name.Reader+import GHC.Types.SourceText import GHC.Types.SrcLoc import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common@@ -27,59 +26,54 @@ p_sigDecl :: Sig GhcPs -> R () p_sigDecl = \case- TypeSig NoExtField names hswc -> p_typeSig True names hswc- PatSynSig NoExtField names hsib -> p_patSynSig names hsib- ClassOpSig NoExtField def names hsib -> p_classOpSig def names hsib- FixSig NoExtField sig -> p_fixSig sig- InlineSig NoExtField name inlinePragma -> p_inlineSig name inlinePragma- SpecSig NoExtField name ts inlinePragma -> p_specSig name ts inlinePragma- SpecInstSig NoExtField _ hsib -> p_specInstSig hsib- MinimalSig NoExtField _ booleanFormula -> p_minimalSig booleanFormula- CompleteMatchSig NoExtField _sourceText cs ty -> p_completeSig cs ty- SCCFunSig NoExtField _ name literal -> p_sccSig name literal+ TypeSig _ names hswc -> p_typeSig True names (hswc_body hswc)+ PatSynSig _ names sigType -> p_patSynSig names sigType+ ClassOpSig _ def names sigType -> p_classOpSig def names sigType+ FixSig _ sig -> p_fixSig sig+ InlineSig _ name inlinePragma -> p_inlineSig name inlinePragma+ SpecSig _ name ts inlinePragma -> p_specSig name ts inlinePragma+ SpecInstSig _ _ sigType -> p_specInstSig sigType+ MinimalSig _ _ booleanFormula -> p_minimalSig booleanFormula+ CompleteMatchSig _ _sourceText cs ty -> p_completeSig cs ty+ SCCFunSig _ _ name literal -> p_sccSig name literal _ -> notImplemented "certain types of signature declarations" p_typeSig :: -- | Should the tail of the names be indented Bool -> -- | Names (before @::@)- [Located RdrName] ->+ [LocatedN RdrName] -> -- | Type- LHsSigWcType GhcPs ->+ LHsSigType GhcPs -> R () p_typeSig _ [] _ = return () -- should not happen though-p_typeSig indentTail (n : ns) hswc = do+p_typeSig indentTail (n : ns) sigType = do p_rdrName n if null ns- then p_typeAscription hswc+ then p_typeAscription sigType else inciIf indentTail $ do commaDel sep commaDel p_rdrName ns- p_typeAscription hswc+ p_typeAscription sigType p_typeAscription ::- LHsSigWcType GhcPs ->+ LHsSigType GhcPs -> R ()-p_typeAscription HsWC {..} = inci $ do+p_typeAscription sigType = inci $ do space txt "::"- let t = hsib_body hswc_body- if hasDocStrings (unLoc t)+ if hasDocStrings (unLoc . sig_body . unLoc $ sigType) then newline else breakpoint- located t p_hsType+ located sigType p_hsSigType p_patSynSig ::- [Located RdrName] ->- HsImplicitBndrs GhcPs (LHsType GhcPs) ->+ [LocatedN RdrName] ->+ LHsSigType GhcPs -> R ()-p_patSynSig names hsib = do+p_patSynSig names sigType = do txt "pattern"- let body =- p_typeSig- False- names- HsWC {hswc_ext = NoExtField, hswc_body = hsib}+ let body = p_typeSig False names sigType if length names > 1 then breakpoint >> inci body else space >> body@@ -88,13 +82,13 @@ -- | Whether this is a \"default\" signature Bool -> -- | Names (before @::@)- [Located RdrName] ->+ [LocatedN RdrName] -> -- | Type- HsImplicitBndrs GhcPs (LHsType GhcPs) ->+ LHsSigType GhcPs -> R ()-p_classOpSig def names hsib = do+p_classOpSig def names sigType = do when def (txt "default" >> space)- p_typeSig True names HsWC {hswc_ext = NoExtField, hswc_body = hsib}+ p_typeSig True names sigType p_fixSig :: FixitySig GhcPs ->@@ -112,7 +106,7 @@ p_inlineSig :: -- | Name- Located RdrName ->+ LocatedN RdrName -> -- | Inline pragma specification InlinePragma -> R ()@@ -123,13 +117,13 @@ ConLike -> txt "CONLIKE" FunLike -> return () space- p_activation inl_act+ when (inl_act /= NeverActive) $ p_activation inl_act space p_rdrName name p_specSig :: -- | Name- Located RdrName ->+ LocatedN RdrName -> -- | The types to specialize to [LHsSigType GhcPs] -> -- | For specialize inline@@ -146,18 +140,18 @@ space txt "::" breakpoint- inci $ sep commaDel (located' p_hsType . hsib_body) ts+ inci $ sep commaDel (located' p_hsSigType) ts p_inlineSpec :: InlineSpec -> R () p_inlineSpec = \case Inline -> txt "INLINE" Inlinable -> txt "INLINEABLE" NoInline -> txt "NOINLINE"- NoUserInline -> return ()+ NoUserInlinePrag -> return () p_activation :: Activation -> R () p_activation = \case- NeverActive -> return ()+ NeverActive -> txt "[~]" AlwaysActive -> return () ActiveBefore _ n -> do txt "[~"@@ -170,13 +164,13 @@ FinalActive -> notImplemented "FinalActive" -- NOTE(amesgen) is this unreachable or just not implemented? p_specInstSig :: LHsSigType GhcPs -> R ()-p_specInstSig hsib =+p_specInstSig sigType = pragma "SPECIALIZE instance" . inci $- located (hsib_body hsib) p_hsType+ located sigType p_hsSigType p_minimalSig :: -- | Boolean formula- LBooleanFormula (Located RdrName) ->+ LBooleanFormula (LocatedN RdrName) -> R () p_minimalSig = located' $ \booleanFormula ->@@ -184,7 +178,7 @@ p_booleanFormula :: -- | Boolean formula- BooleanFormula (Located RdrName) ->+ BooleanFormula (LocatedN RdrName) -> R () p_booleanFormula = \case Var name -> p_rdrName name@@ -204,9 +198,9 @@ p_completeSig :: -- | Constructors\/patterns- Located [Located RdrName] ->+ Located [LocatedN RdrName] -> -- | Type- Maybe (Located RdrName) ->+ Maybe (LocatedN RdrName) -> R () p_completeSig cs' mty = located cs' $ \cs ->@@ -218,7 +212,7 @@ breakpoint inci (p_rdrName ty) -p_sccSig :: Located (IdP GhcPs) -> Maybe (Located StringLiteral) -> R ()+p_sccSig :: LocatedN RdrName -> Maybe (Located StringLiteral) -> R () p_sccSig loc literal = pragma "SCC" . inci $ do p_rdrName loc forM_ literal $ \x -> do@@ -226,7 +220,7 @@ atom x p_standaloneKindSig :: StandaloneKindSig GhcPs -> R ()-p_standaloneKindSig (StandaloneKindSig NoExtField name (HsIB NoExtField sig)) = do+p_standaloneKindSig (StandaloneKindSig _ name sigTy) = do txt "type" inci $ do space@@ -234,4 +228,4 @@ space txt "::" breakpoint- located sig p_hsType+ located sigTy p_hsSigType
src/Ormolu/Printer/Meat/Declaration/Splice.hs view
@@ -5,8 +5,7 @@ ) where -import GHC.Hs.Decls-import GHC.Hs.Extension+import GHC.Hs import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Declaration.Value (p_hsSplice)
src/Ormolu/Printer/Meat/Declaration/Type.hs view
@@ -9,7 +9,8 @@ import GHC.Hs.Extension import GHC.Hs.Type-import GHC.Types.Basic+import GHC.Parser.Annotation+import GHC.Types.Fixity import GHC.Types.Name.Reader import GHC.Types.SrcLoc import Ormolu.Printer.Combinators@@ -18,7 +19,7 @@ p_synDecl :: -- | Type constructor- Located RdrName ->+ LocatedN RdrName -> -- | Fixity LexicalFixity -> -- | Type variables@@ -29,7 +30,7 @@ p_synDecl name fixity HsQTvs {..} t = do txt "type" space- switchLayout (getLoc name : map getLoc hsq_explicit) $+ switchLayout (getLocA name : map getLocA hsq_explicit) $ p_infixDefHelper (case fixity of Infix -> True; _ -> False) True
src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs view
@@ -11,10 +11,8 @@ import Control.Monad import Data.Maybe (isNothing)-import GHC.Hs.Decls-import GHC.Hs.Extension-import GHC.Hs.Type-import GHC.Types.Basic+import GHC.Hs+import GHC.Types.Fixity import GHC.Types.SrcLoc import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common@@ -29,9 +27,11 @@ txt $ case style of Associated -> mempty Free -> " family"- breakpoint- inci $ do- switchLayout (getLoc fdLName : (getLoc <$> hsq_explicit)) $+ let headerSpns = getLocA fdLName : (getLocA <$> hsq_explicit)+ headerAndSigSpns = getLoc fdResultSig : headerSpns+ inci . switchLayout headerAndSigSpns $ do+ breakpoint+ switchLayout headerSpns $ do p_infixDefHelper (isInfix fdFixity) True@@ -46,7 +46,7 @@ case mmeqs of Nothing -> return () Just meqs -> do- inci $ do+ inci . switchLayout headerAndSigSpns $ do breakpoint txt "where" case meqs of@@ -72,7 +72,7 @@ located bndr p_hsTyVarBndr p_injectivityAnn :: InjectivityAnn GhcPs -> R ()-p_injectivityAnn (InjectivityAnn a bs) = do+p_injectivityAnn (InjectivityAnn _ a bs) = do txt "|" space p_rdrName a@@ -82,14 +82,17 @@ sep space p_rdrName bs p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R ()-p_tyFamInstEqn HsIB {hsib_body = FamEqn {..}} = do+p_tyFamInstEqn FamEqn {..} = do case feqn_bndrs of- Nothing -> return ()- Just bndrs -> do+ HsOuterImplicit NoExtField -> return ()+ HsOuterExplicit _ bndrs -> do p_forallBndrs ForAllInvis p_hsTyVarBndr bndrs breakpoint- inciIf (not $ null feqn_bndrs) $ do- let famLhsSpn = getLoc feqn_tycon : fmap lhsTypeArgSrcSpan feqn_pats+ let atLeastOneBndr = case feqn_bndrs of+ HsOuterImplicit NoExtField -> False+ HsOuterExplicit _ bndrs -> not $ null bndrs+ inciIf atLeastOneBndr $ do+ let famLhsSpn = getLocA feqn_tycon : fmap lhsTypeArgSrcSpan feqn_pats switchLayout famLhsSpn $ p_infixDefHelper (isInfix feqn_fixity)
src/Ormolu/Printer/Meat/Declaration/Value.hs view
@@ -1,9 +1,11 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module Ormolu.Printer.Meat.Declaration.Value@@ -17,7 +19,7 @@ import Control.Monad import Data.Bool (bool)-import Data.Char (isPunctuation, isSymbol)+import Data.Coerce (coerce) import Data.Data hiding (Infix, Prefix) import Data.Function (on) import Data.Functor ((<&>))@@ -25,25 +27,22 @@ import Data.List (intersperse, sortBy) import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as NE-import Data.Maybe (isJust)+import Data.Maybe import Data.Text (Text) import qualified Data.Text as Text+import Data.Void import GHC.Data.Bag (bagToList)-import GHC.Hs.Binds-import GHC.Hs.Expr-import GHC.Hs.Extension-import GHC.Hs.Lit-import GHC.Hs.Pat-import GHC.Hs.Type+import GHC.Data.FastString (FastString, lengthFS)+import GHC.Hs import GHC.LanguageExtensions.Type (Extension (NegativeLiterals))-import GHC.Parser.Annotation import GHC.Parser.CharClass (is_space) import GHC.Types.Basic+import GHC.Types.Fixity import GHC.Types.Name.Occurrence (occNameString) import GHC.Types.Name.Reader+import GHC.Types.SourceText import GHC.Types.SrcLoc import Ormolu.Printer.Combinators-import Ormolu.Printer.Internal import Ormolu.Printer.Meat.Common import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration import Ormolu.Printer.Meat.Declaration.Signature@@ -53,7 +52,7 @@ -- | Style of a group of equations. data MatchGroupStyle- = Function (Located RdrName)+ = Function (LocatedN RdrName) | PatternBind | Case | Lambda@@ -79,14 +78,14 @@ p_valDecl :: HsBindLR GhcPs GhcPs -> R () p_valDecl = \case- FunBind NoExtField funId funMatches _ -> p_funBind funId funMatches- PatBind NoExtField pat grhss _ -> p_match PatternBind False NoSrcStrict [pat] grhss+ FunBind _ funId funMatches _ -> p_funBind funId funMatches+ PatBind _ pat grhss _ -> p_match PatternBind False NoSrcStrict [pat] grhss VarBind {} -> notImplemented "VarBinds" -- introduced by the type checker AbsBinds {} -> notImplemented "AbsBinds" -- introduced by the type checker- PatSynBind NoExtField psb -> p_patSynBind psb+ PatSynBind _ psb -> p_patSynBind psb p_funBind ::- Located RdrName ->+ LocatedN RdrName -> MatchGroup GhcPs (LHsExpr GhcPs) -> R () p_funBind name = p_matchGroup (Function name)@@ -98,7 +97,9 @@ p_matchGroup = p_matchGroup' exprPlacement p_hsExpr p_matchGroup' ::- Data body =>+ ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcSpan,+ Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA+ ) => -- | How to get body placement (body -> Placement) -> -- | How to print body@@ -106,7 +107,7 @@ -- | Style of this group of equations MatchGroupStyle -> -- | Match group- MatchGroup GhcPs (Located body) ->+ MatchGroup GhcPs (LocatedA body) -> R () p_matchGroup' placer render style mg@MG {..} = do let ob = case style of@@ -165,7 +166,7 @@ p_match = p_match' exprPlacement p_hsExpr p_match' ::- Data body =>+ (Anno (GRHS GhcPs (LocatedA body)) ~ SrcSpan) => -- | How to get body placement (body -> Placement) -> -- | How to print body@@ -179,7 +180,7 @@ -- | Argument patterns [LPat GhcPs] -> -- | Equations- GRHSs GhcPs (Located body) ->+ GRHSs GhcPs (LocatedA body) -> R () p_match' placer render style isInfix strictness m_pats GRHSs {..} = do -- Normally, since patterns may be placed in a multi-line layout, it is@@ -200,9 +201,9 @@ _ -> return () Just ne_pats -> do let combinedSpans = case style of- Function name -> combineSrcSpans (getLoc name) patSpans+ Function name -> combineSrcSpans (getLocA name) patSpans _ -> patSpans- patSpans = combineSrcSpans' (getLoc <$> ne_pats)+ patSpans = combineSrcSpans' (getLocA <$> ne_pats) indentBody = not (isOneLineSpan combinedSpans) switchLayout [combinedSpans] $ do let stdCase = sep breakpoint (located' p_pat) m_pats@@ -230,9 +231,9 @@ -- about putting certain constructions in hanging positions. endOfPats = case NE.nonEmpty m_pats of Nothing -> case style of- Function name -> Just (getLoc name)+ Function name -> Just (getLocA name) _ -> Nothing- Just pats -> (Just . getLoc . NE.last) pats+ Just pats -> (Just . getLocA . NE.last) pats isCase = \case Case -> True LambdaCase -> True@@ -251,26 +252,28 @@ Just spn | any guardNeedsLineBreak grhssGRHSs || not (onTheSameLine spn grhssSpan) ->- Normal+ Normal _ -> blockPlacement placer grhssGRHSs guardNeedsLineBreak :: Located (GRHS GhcPs body) -> Bool guardNeedsLineBreak (L _ (GRHS _ guardLStmts _)) = case guardLStmts of [] -> False- [L l _] -> not (isOneLineSpan l)+ [g] -> not . isOneLineSpan . getLocA $ g _ -> True p_body = do let groupStyle = if isCase style && hasGuards then RightArrow else EqualSign- sep breakpoint (located' (p_grhs' placer render groupStyle)) grhssGRHSs+ sep+ breakpoint+ (located' (p_grhs' placement placer render groupStyle) . reLocA)+ grhssGRHSs p_where = do- let whereIsEmpty = eqEmptyLocalBinds (unLoc grhssLocalBinds)- unless (eqEmptyLocalBinds (unLoc grhssLocalBinds)) $ do+ unless (eqEmptyLocalBinds grhssLocalBinds) $ do breakpoint txt "where"- unless whereIsEmpty breakpoint- inci $ located grhssLocalBinds p_hsLocalBinds+ breakpoint+ inci $ p_hsLocalBinds grhssLocalBinds inciIf indentBody $ do unless (length grhssGRHSs > 1) $ case style of@@ -284,18 +287,19 @@ inci p_where p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R ()-p_grhs = p_grhs' exprPlacement p_hsExpr+p_grhs = p_grhs' Normal exprPlacement p_hsExpr p_grhs' ::- Data body =>+ -- | Placement of the parent RHS construct+ Placement -> -- | How to get body placement (body -> Placement) -> -- | How to print body (body -> R ()) -> GroupStyle ->- GRHS GhcPs (Located body) ->+ GRHS GhcPs (LocatedA body) -> R ()-p_grhs' placer render style (GRHS NoExtField guards body) =+p_grhs' parentPlacement placer render style (GRHS _ guards body) = case guards of [] -> p_body xs -> do@@ -306,19 +310,23 @@ inci $ case style of EqualSign -> equals RightArrow -> txt "->"- placeHanging placement p_body+ -- If we have a sequence of guards and it is placed in the normal way,+ -- then we indent one level more for readability. Otherwise (all+ -- guards are on the same line) we do not need to indent, as it would+ -- look like double indentation without a good reason.+ inciIf (parentPlacement == Normal) (placeHanging placement p_body) where placement = case endOfGuards of Nothing -> placer (unLoc body) Just spn ->- if onTheSameLine spn (getLoc body)+ if onTheSameLine spn (getLocA body) then placer (unLoc body) else Normal endOfGuards = case NE.nonEmpty guards of Nothing -> Nothing- Just gs -> (Just . getLoc . NE.last) gs+ Just gs -> (Just . getLocA . NE.last) gs p_body = located body render p_hsCmd :: HsCmd GhcPs -> R ()@@ -326,7 +334,7 @@ p_hsCmd' :: BracketStyle -> HsCmd GhcPs -> R () p_hsCmd' s = \case- HsCmdArrApp NoExtField body input arrType rightToLeft -> do+ HsCmdArrApp _ body input arrType rightToLeft -> do let (l, r) = if rightToLeft then (body, input) else (input, body) located l p_hsExpr breakpoint@@ -338,35 +346,35 @@ (HsHigherOrderApp, False) -> txt ">>-" placeHanging (exprPlacement (unLoc input)) $ located r p_hsExpr- HsCmdArrForm NoExtField form Prefix _ cmds -> banana s $ do+ HsCmdArrForm _ form Prefix _ cmds -> banana s $ do located form p_hsExpr unless (null cmds) $ do breakpoint inci (sequence_ (intersperse breakpoint (located' p_hsCmdTop <$> cmds)))- HsCmdArrForm NoExtField form Infix _ [left, right] ->+ HsCmdArrForm _ form Infix _ [left, right] -> let opTree = OpBranch (cmdOpTree left) form (cmdOpTree right) in p_cmdOpTree (reassociateOpTree getOpName opTree)- HsCmdArrForm NoExtField _ Infix _ _ -> notImplemented "HsCmdArrForm"- HsCmdApp NoExtField cmd expr -> do+ HsCmdArrForm _ _ Infix _ _ -> notImplemented "HsCmdArrForm"+ HsCmdApp _ cmd expr -> do located cmd (p_hsCmd' s) space located expr p_hsExpr- HsCmdLam NoExtField mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup- HsCmdPar NoExtField c -> parens N (located c p_hsCmd)- HsCmdCase NoExtField e mgroup ->+ HsCmdLam _ mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup+ HsCmdPar _ c -> parens N (located c p_hsCmd)+ HsCmdCase _ e mgroup -> p_case cmdPlacement p_hsCmd e mgroup- HsCmdLamCase NoExtField mgroup ->+ HsCmdLamCase _ mgroup -> p_lamcase cmdPlacement p_hsCmd mgroup- HsCmdIf NoExtField _ if' then' else' ->+ HsCmdIf _ _ if' then' else' -> p_if cmdPlacement p_hsCmd if' then' else'- HsCmdLet NoExtField localBinds c ->+ HsCmdLet _ localBinds c -> p_let p_hsCmd localBinds c- HsCmdDo NoExtField es -> do+ HsCmdDo _ es -> do txt "do" p_stmts cmdPlacement (p_hsCmd' S) es p_hsCmdTop :: HsCmdTop GhcPs -> R ()-p_hsCmdTop (HsCmdTop NoExtField cmd) = located cmd p_hsCmd+p_hsCmdTop (HsCmdTop _ cmd) = located cmd p_hsCmd -- | Render an expression preserving blank lines between such consecutive -- expressions found in the original source code.@@ -374,10 +382,10 @@ -- | Rendering function (a -> R ()) -> -- | Entity to render- Located a ->+ LocatedAn ann a -> R () withSpacing f l = located l $ \x -> do- case getLoc l of+ case getLocA l of UnhelpfulSpan _ -> f x RealSrcSpan currentSpn _ -> do getSpanMark >>= \case@@ -401,32 +409,34 @@ p_stmt = p_stmt' exprPlacement p_hsExpr p_stmt' ::- Data body =>+ ( Anno (Stmt GhcPs (LocatedA body)) ~ SrcSpanAnnA,+ Anno [LocatedA (Stmt GhcPs (LocatedA body))] ~ SrcSpanAnnL+ ) => -- | Placer (body -> Placement) -> -- | Render (body -> R ()) -> -- | Statement to render- Stmt GhcPs (Located body) ->+ Stmt GhcPs (LocatedA body) -> R () p_stmt' placer render = \case- LastStmt NoExtField body _ _ -> located body render- BindStmt NoExtField p f@(L l x) -> do+ LastStmt _ body _ _ -> located body render+ BindStmt _ p f@(getLocA -> l) -> do located p p_pat space txt "<-"- let loc = getLoc p+ let loc = getLocA p placement- | isOneLineSpan (mkSrcSpan (srcSpanEnd loc) (srcSpanStart l)) = placer x+ | isOneLineSpan (mkSrcSpan (srcSpanEnd loc) (srcSpanStart l)) = placer (unLoc f) | otherwise = Normal switchLayout [loc, l] $ placeHanging placement (located f render) ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer- BodyStmt NoExtField body _ _ -> located body render- LetStmt NoExtField binds -> do+ BodyStmt _ body _ _ -> located body render+ LetStmt _ binds -> do txt "let" space- sitcc $ located binds p_hsLocalBinds+ sitcc $ p_hsLocalBinds binds ParStmt {} -> -- 'ParStmt' should always be eliminated in 'gatherStmt' already, such -- that it never occurs in 'p_stmt''. Consequently, handling it here@@ -464,16 +474,18 @@ RecStmt {..} -> do txt "rec" space- sitcc $ sepSemi (withSpacing (p_stmt' placer render)) recS_stmts+ sitcc . located recS_stmts $ sepSemi (withSpacing (p_stmt' placer render)) p_stmts ::- Data body =>+ ( Anno (Stmt GhcPs (LocatedA body)) ~ SrcSpanAnnA,+ Anno [LocatedA (Stmt GhcPs (LocatedA body))] ~ SrcSpanAnnL+ ) => -- | Placer (body -> Placement) -> -- | Render (body -> R ()) -> -- | Statements to render- Located [Located (Stmt GhcPs (Located body))] ->+ LocatedL [LocatedA (Stmt GhcPs (LocatedA body))] -> R () p_stmts placer render es = do breakpoint@@ -483,7 +495,7 @@ (ub . withSpacing (p_stmt' placer render)) gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]-gatherStmt (L _ (ParStmt NoExtField block _ _)) =+gatherStmt (L _ (ParStmt _ block _ _)) = foldr ((<>) . gatherStmtBlock) [] block gatherStmt (L s stmt@TransStmt {..}) = foldr liftAppend [] ((gatherStmt <$> trS_stmts) <> pure [[L s stmt]])@@ -493,9 +505,9 @@ gatherStmtBlock (ParStmtBlock _ stmts _ _) = foldr (liftAppend . gatherStmt) [] stmts -p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()+p_hsLocalBinds :: HsLocalBinds GhcPs -> R () p_hsLocalBinds = \case- HsValBinds NoExtField (ValBinds NoExtField bag lsigs) -> do+ HsValBinds epAnn (ValBinds _ bag lsigs) -> pseudoLocated epAnn $ do -- When in a single-line layout, there is a chance that the inner -- elements will also contain semicolons and they will confuse the -- parser. so we request braces around every element except the last.@@ -512,33 +524,63 @@ p_item' (p, item) = positionToBracing p $ withSpacing (either p_valDecl p_sigDecl) item- binds = sortBy (leftmost_smallest `on` getLoc) items+ binds = sortBy (leftmost_smallest `on` getLocA) items sitcc $ sepSemi p_item' (attachRelativePos binds)- HsValBinds NoExtField _ -> notImplemented "HsValBinds"- HsIPBinds NoExtField (IPBinds NoExtField xs) ->+ HsValBinds _ _ -> notImplemented "HsValBinds"+ HsIPBinds epAnn (IPBinds _ xs) -> pseudoLocated epAnn $ do -- Second argument of IPBind is always Left before type-checking.- let p_ipBind (IPBind NoExtField (Left name) expr) = do+ let p_ipBind (IPBind _ (Left name) expr) = do atom name space equals breakpoint useBraces $ inci $ located expr p_hsExpr- p_ipBind (IPBind NoExtField (Right _) _) =+ p_ipBind (IPBind _ (Right _) _) = -- Should only occur after the type checker notImplemented "IPBind _ (Right _) _"- in sepSemi (located' p_ipBind) xs- EmptyLocalBinds NoExtField -> return ()+ sepSemi (located' p_ipBind) xs+ EmptyLocalBinds _ -> return ()+ where+ -- HsLocalBinds is no longer wrapped in a Located (see call sites+ -- of p_hsLocalBinds). Hence, we introduce a manual Located as we+ -- depend on the layout being correctly set.+ pseudoLocated = \case+ EpAnn {anns = AnnList {al_anchor = Just Anchor {anchor}}} ->+ located (L (RealSrcSpan anchor Nothing) ()) . const+ _ -> id +p_lhsFieldLabel :: Located (HsFieldLabel GhcPs) -> R ()+p_lhsFieldLabel = located' $ p_lFieldLabelString . hflLabel+ where+ p_lFieldLabelString (L s fs) = parensIfOp . atom @FastString $ fs+ where+ -- HACK For OverloadedRecordUpdate:+ -- In operator field updates (i.e. `f {(+) = 1}`), we don't have+ -- information whether parens are necessary. As a workaround,+ -- we look if the RealSrcSpan is bigger than the string fs.+ parensIfOp+ | isOneLineSpan s,+ Just realS <- srcSpanToRealSrcSpan s,+ let spanLength = srcSpanEndCol realS - srcSpanStartCol realS,+ lengthFS fs < spanLength =+ parens N+ | otherwise = id++p_fieldLabels :: [Located (HsFieldLabel GhcPs)] -> R ()+p_fieldLabels flss =+ sep (txt ".") p_lhsFieldLabel flss+ p_hsRecField ::- HsRecField' RdrName (LHsExpr GhcPs) ->+ (id -> R ()) ->+ HsRecField' id (LHsExpr GhcPs) -> R ()-p_hsRecField HsRecField {..} = do- p_rdrName hsRecFieldLbl+p_hsRecField p_lbl HsRecField {..} = do+ located hsRecFieldLbl p_lbl unless hsRecPun $ do space equals let placement =- if onTheSameLine (getLoc hsRecFieldLbl) (getLoc hsRecFieldArg)+ if onTheSameLine (getLoc hsRecFieldLbl) (getLocA hsRecFieldArg) then exprPlacement (unLoc hsRecFieldArg) else Normal placeHanging placement (located hsRecFieldArg p_hsExpr)@@ -548,30 +590,30 @@ p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R () p_hsExpr' s = \case- HsVar NoExtField name -> p_rdrName name- HsUnboundVar NoExtField occ -> atom occ- HsConLikeOut NoExtField _ -> notImplemented "HsConLikeOut"- HsRecFld NoExtField x ->+ HsVar _ name -> p_rdrName name+ HsUnboundVar _ occ -> atom occ+ HsConLikeOut _ _ -> notImplemented "HsConLikeOut"+ HsRecFld _ x -> case x of- Unambiguous NoExtField name -> p_rdrName name- Ambiguous NoExtField name -> p_rdrName name- HsOverLabel NoExtField _ v -> do+ Unambiguous _ name -> p_rdrName name+ Ambiguous _ name -> p_rdrName name+ HsOverLabel _ v -> do txt "#" atom v- HsIPVar NoExtField (HsIPName name) -> do+ HsIPVar _ (HsIPName name) -> do txt "?" atom name- HsOverLit NoExtField v -> atom (ol_val v)- HsLit NoExtField lit ->+ HsOverLit _ v -> atom (ol_val v)+ HsLit _ lit -> case lit of HsString (SourceText stxt) _ -> p_stringLit stxt HsStringPrim (SourceText stxt) _ -> p_stringLit stxt r -> atom r- HsLam NoExtField mgroup ->+ HsLam _ mgroup -> p_matchGroup Lambda mgroup- HsLamCase NoExtField mgroup ->+ HsLamCase _ mgroup -> p_lamcase exprPlacement p_hsExpr mgroup- HsApp NoExtField f x -> do+ HsApp _ f x -> do let -- In order to format function applications with multiple parameters -- nicer, traverse the AST to gather the function and all the -- parameters together.@@ -585,7 +627,7 @@ (initp, lastp) = (NE.init args, NE.last args) initSpan = combineSrcSpans' $- getLoc f :| [(srcLocSpan . srcSpanStart . getLoc) lastp]+ getLocA f :| [(srcLocSpan . srcSpanStart . getLocA) lastp] -- Hang the last argument only if the initial arguments span one -- line. placement =@@ -607,12 +649,12 @@ -- Thus, we indent by half of indentStep when the function is -- a multi line do block or case expression. indentArg- | isOneLineSpan (getLoc func) = inci+ | isOneLineSpan (getLocA func) = inci | otherwise = case unLoc func of- HsDo {} -> inciHalf- HsCase {} -> inciHalf- HsLamCase {} -> inciHalf- _ -> inci+ HsDo {} -> inciHalf+ HsCase {} -> inciHalf+ HsLamCase {} -> inciHalf+ _ -> inci ub <- getLayout <&> \case SingleLine -> useBraces@@ -631,7 +673,7 @@ sep breakpoint (located' p_hsExpr) initp placeHanging placement . dontUseBraces $ located lastp p_hsExpr- HsAppType NoExtField e a -> do+ HsAppType _ e a -> do located e p_hsExpr breakpoint inci $ do@@ -642,10 +684,10 @@ HsSpliceTy {} -> space _ -> return () located (hswc_body a) p_hsType- OpApp NoExtField x op y -> do+ OpApp _ x op y -> do let opTree = OpBranch (exprOpTree x) op (exprOpTree y) p_exprOpTree s (reassociateOpTree getOpName opTree)- NegApp NoExtField e NoExtField -> do+ NegApp _ e _ -> do negativeLiterals <- isExtensionEnabled NegativeLiterals let isLiteral = case unLoc e of HsLit {} -> True@@ -656,51 +698,49 @@ -- negated literals, as `- 1` and `-1` have differing AST. when (negativeLiterals && isLiteral) space located e p_hsExpr- HsPar NoExtField e ->+ HsPar _ e -> parens s (located e (dontUseBraces . p_hsExpr))- SectionL NoExtField x op -> do+ SectionL _ x op -> do located x p_hsExpr breakpoint inci (located op p_hsExpr)- SectionR NoExtField op x -> do+ SectionR _ op x -> do located op p_hsExpr- useRecordDot' <- useRecordDot- let isRecordDot' = isRecordDot (unLoc op) (getLoc x)- unless (useRecordDot' && isRecordDot') breakpoint+ breakpoint inci (located x p_hsExpr)- ExplicitTuple NoExtField args boxity ->- let isSection = any (isMissing . unLoc) args+ ExplicitTuple _ args boxity -> do+ let isSection = any isMissing args isMissing = \case- Missing NoExtField -> True+ Missing _ -> True _ -> False p_arg = \case- Present NoExtField x -> located x p_hsExpr- Missing NoExtField -> pure ()- p_larg = sitcc . located' p_arg+ Present _ x -> located x p_hsExpr+ Missing _ -> pure () parens' = case boxity of Boxed -> parens Unboxed -> parensHash- in if isSection- then- switchLayout [] . parens' s $- sep comma p_larg args- else- switchLayout (getLoc <$> args) . parens' s $- sep commaDel p_larg args- ExplicitSum NoExtField tag arity e ->+ enclSpan <- fmap (flip RealSrcSpan Nothing) . maybeToList <$> getEnclosingSpan (const True)+ if isSection+ then+ switchLayout [] . parens' s $+ sep comma p_arg args+ else+ switchLayout enclSpan . parens' s $+ sep commaDel p_arg args+ ExplicitSum _ tag arity e -> p_unboxedSum N tag arity (located e p_hsExpr)- HsCase NoExtField e mgroup ->+ HsCase _ e mgroup -> p_case exprPlacement p_hsExpr e mgroup- HsIf NoExtField if' then' else' ->+ HsIf _ if' then' else' -> p_if exprPlacement p_hsExpr if' then' else'- HsMultiIf NoExtField guards -> do+ HsMultiIf _ guards -> do txt "if" breakpoint inci . inci $ sep newline (located' (p_grhs RightArrow)) guards- HsLet NoExtField localBinds e ->+ HsLet _ localBinds e -> p_let p_hsExpr localBinds e- HsDo NoExtField ctx es -> do+ HsDo _ ctx es -> do let doBody moduleName header = do forM_ moduleName $ \m -> atom m *> txt "." txt header@@ -733,19 +773,15 @@ PatGuard _ -> notImplemented "PatGuard" ParStmtCtxt _ -> notImplemented "ParStmtCtxt" TransStmtCtxt _ -> notImplemented "TransStmtCtxt"- ExplicitList _ _ xs ->+ ExplicitList _ xs -> brackets s $ sep commaDel (sitcc . located' p_hsExpr) xs RecordCon {..} -> do- located rcon_con_name atom+ located rcon_con atom breakpoint let HsRecFields {..} = rcon_flds- updName f =- (f :: HsRecField GhcPs (LHsExpr GhcPs))- { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of- FieldOcc _ n -> n- }- fields = located' (p_hsRecField . updName) <$> rec_flds+ p_lbl = p_rdrName . rdrNameFieldOcc+ fields = located' (p_hsRecField p_lbl) <$> rec_flds dotdot = case rec_dotdot of Just {} -> [txt ".."]@@ -754,37 +790,32 @@ sep commaDel sitcc (fields <> dotdot) RecordUpd {..} -> do located rupd_expr p_hsExpr- useRecordDot' <- useRecordDot- let mrs sp = case getLoc sp of- RealSrcSpan r _ -> Just r- _ -> Nothing- let isPluginForm =- ((1 +) . srcSpanEndCol <$> mrs rupd_expr)- == (srcSpanStartCol <$> mrs (head rupd_flds))- && onTheSameLine (getLoc rupd_expr) (getLoc $ head rupd_flds)- unless (useRecordDot' && isPluginForm) breakpoint- let updName f =- (f :: HsRecUpdField GhcPs)- { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of- Ambiguous _ n -> n- Unambiguous _ n -> n- }- updBraces =- if useRecordDot' && isPluginForm- then recordDotBraces- else inci . braces N- updBraces $- sep- commaDel- (sitcc . located' (p_hsRecField . updName))+ breakpoint+ let p_updLbl =+ p_rdrName . \case+ Unambiguous NoExtField n -> n+ Ambiguous NoExtField n -> n+ p_recFields p_lbl =+ sep commaDel (sitcc . located' (p_hsRecField p_lbl))+ inci . braces N $+ either+ (p_recFields p_updLbl)+ (p_recFields (p_fieldLabels . coerce)) rupd_flds- ExprWithTySig NoExtField x HsWC {hswc_body = HsIB {..}} -> sitcc $ do+ HsGetField {..} -> do+ located gf_expr p_hsExpr+ txt "."+ p_lhsFieldLabel gf_field+ HsProjection {..} -> parens N $ do+ txt "."+ p_fieldLabels (NE.toList proj_flds)+ ExprWithTySig _ x HsWC {hswc_body} -> sitcc $ do located x p_hsExpr space txt "::" breakpoint- inci $ located hsib_body p_hsType- ArithSeq NoExtField _ x ->+ inci $ located hswc_body p_hsSigType+ ArithSeq _ _ x -> case x of From from -> brackets s $ do located from p_hsExpr@@ -806,11 +837,11 @@ txt ".." space located to p_hsExpr- HsBracket NoExtField x -> p_hsBracket x+ HsBracket epAnn x -> p_hsBracket epAnn x HsRnBracketOut {} -> notImplemented "HsRnBracketOut" HsTcBracketOut {} -> notImplemented "HsTcBracketOut"- HsSpliceE NoExtField splice -> p_hsSplice splice- HsProc NoExtField p e -> do+ HsSpliceE _ splice -> p_hsSplice splice+ HsProc _ p e -> do txt "proc" located p $ \x -> do breakpoint@@ -825,14 +856,13 @@ inci (located e p_hsExpr) HsTick {} -> notImplemented "HsTick" HsBinTick {} -> notImplemented "HsBinTick"- HsPragE NoExtField prag x -> case prag of- HsPragSCC NoExtField _ name -> do+ HsPragE _ prag x -> case prag of+ HsPragSCC _ _ name -> do txt "{-# SCC " atom name txt " #-}" breakpoint located x p_hsExpr- HsPragTick {} -> notImplemented "HsTickPragma" p_patSynBind :: PatSynBind GhcPs GhcPs -> R () p_patSynBind PSB {..} = do@@ -857,25 +887,26 @@ inci (p_matchGroup (Function psb_id) mgroup) txt "pattern" case psb_args of- PrefixCon xs -> do+ PrefixCon [] xs -> do space p_rdrName psb_id inci $ do- switchLayout (getLoc <$> xs) $ do+ switchLayout (getLocA <$> xs) $ do unless (null xs) breakpoint sitcc (sep breakpoint p_rdrName xs) rhs+ PrefixCon (v : _) _ -> absurd v RecCon xs -> do space p_rdrName psb_id inci $ do- switchLayout (getLoc . recordPatSynPatVar <$> xs) $ do+ switchLayout (getLocA . recordPatSynPatVar <$> xs) $ do unless (null xs) breakpoint braces N $ sep commaDel (p_rdrName . recordPatSynPatVar) xs rhs InfixCon l r -> do- switchLayout [getLoc l, getLoc r] $ do+ switchLayout [getLocA l, getLocA r] $ do space p_rdrName l breakpoint@@ -886,7 +917,9 @@ inci rhs p_case ::- Data body =>+ ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcSpan,+ Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA+ ) => -- | Placer (body -> Placement) -> -- | Render@@ -894,7 +927,7 @@ -- | Expression LHsExpr GhcPs -> -- | Match group- MatchGroup GhcPs (Located body) ->+ MatchGroup GhcPs (LocatedA body) -> R () p_case placer render e mgroup = do txt "case"@@ -906,13 +939,15 @@ inci (p_matchGroup' placer render Case mgroup) p_lamcase ::- Data body =>+ ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcSpan,+ Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA+ ) => -- | Placer (body -> Placement) -> -- | Render (body -> R ()) -> -- | Expression- MatchGroup GhcPs (Located body) ->+ MatchGroup GhcPs (LocatedA body) -> R () p_lamcase placer render mgroup = do txt "\\case"@@ -920,7 +955,6 @@ inci (p_matchGroup' placer render LambdaCase mgroup) p_if ::- Data body => -- | Placer (body -> Placement) -> -- | Render@@ -928,9 +962,9 @@ -- | If LHsExpr GhcPs -> -- | Then- Located body ->+ LocatedA body -> -- | Else- Located body ->+ LocatedA body -> R () p_if placer render if' then' else' = do txt "if"@@ -949,16 +983,15 @@ placeHanging (placer x) (render x) p_let ::- Data body => -- | Render (body -> R ()) ->- Located (HsLocalBindsLR GhcPs GhcPs) ->- Located body ->+ HsLocalBinds GhcPs ->+ LocatedA body -> R () p_let render localBinds e = sitcc $ do txt "let" space- dontUseBraces $ sitcc (located localBinds p_hsLocalBinds)+ dontUseBraces $ sitcc (p_hsLocalBinds localBinds) vlayout space (newline >> txt " ") txt "in" space@@ -966,37 +999,39 @@ p_pat :: Pat GhcPs -> R () p_pat = \case- WildPat NoExtField -> txt "_"- VarPat NoExtField name -> p_rdrName name- LazyPat NoExtField pat -> do+ WildPat _ -> txt "_"+ VarPat _ name -> p_rdrName name+ LazyPat _ pat -> do txt "~" located pat p_pat- AsPat NoExtField name pat -> do+ AsPat _ name pat -> do p_rdrName name txt "@" located pat p_pat- ParPat NoExtField pat ->+ ParPat _ pat -> located pat (parens S . p_pat)- BangPat NoExtField pat -> do+ BangPat _ pat -> do txt "!" located pat p_pat- ListPat NoExtField pats ->+ ListPat _ pats -> brackets S $ sep commaDel (located' p_pat) pats- TuplePat NoExtField pats boxing -> do+ TuplePat _ pats boxing -> do let parens' = case boxing of Boxed -> parens S Unboxed -> parensHash S parens' $ sep commaDel (sitcc . located' p_pat) pats- SumPat NoExtField pat tag arity ->+ SumPat _ pat tag arity -> p_unboxedSum S tag arity (located pat p_pat)- ConPat NoExtField pat details ->+ ConPat _ pat details -> case details of- PrefixCon xs -> sitcc $ do+ PrefixCon [] xs -> sitcc $ do p_rdrName pat unless (null xs) $ do breakpoint inci . sitcc $ sep breakpoint (sitcc . located' p_pat) xs+ -- The first field of PrefixCon is filled in later stages+ PrefixCon {} -> notImplemented "Unexpected types in constructor pattern" RecCon (HsRecFields fields dotdot) -> do p_rdrName pat breakpoint@@ -1008,42 +1043,41 @@ Nothing -> Just <$> fields Just (L _ n) -> (Just <$> take n fields) ++ [Nothing] InfixCon l r -> do- switchLayout [getLoc l, getLoc r] $ do+ switchLayout [getLocA l, getLocA r] $ do located l p_pat breakpoint inci $ do p_rdrName pat space located r p_pat- ViewPat NoExtField expr pat -> sitcc $ do+ ViewPat _ expr pat -> sitcc $ do located expr p_hsExpr space txt "->" breakpoint inci (located pat p_pat)- SplicePat NoExtField splice -> p_hsSplice splice- LitPat NoExtField p -> atom p- NPat NoExtField v (isJust -> isNegated) NoExtField -> do+ SplicePat _ splice -> p_hsSplice splice+ LitPat _ p -> atom p+ NPat _ v (isJust -> isNegated) _ -> do when isNegated $ do txt "-" negativeLiterals <- isExtensionEnabled NegativeLiterals when negativeLiterals space located v (atom . ol_val)- NPlusKPat NoExtField n k _ _ _ -> sitcc $ do+ NPlusKPat _ n k _ _ _ -> sitcc $ do p_rdrName n breakpoint inci $ do txt "+" space located k (atom . ol_val)- SigPat NoExtField pat HsPS {..} -> do+ SigPat _ pat HsPS {..} -> do located pat p_pat- p_typeAscription (HsWC NoExtField (HsIB NoExtField hsps_body))+ p_typeAscription (lhsTypeToSigType hsps_body) p_pat_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R () p_pat_hsRecField HsRecField {..} = do- located hsRecFieldLbl $ \x ->- p_rdrName (rdrNameFieldOcc x)+ located hsRecFieldLbl $ p_rdrName . rdrNameFieldOcc unless hsRecPun $ do space equals@@ -1067,11 +1101,11 @@ p_hsSplice :: HsSplice GhcPs -> R () p_hsSplice = \case- HsTypedSplice NoExtField deco _ expr -> p_hsSpliceTH True expr deco- HsUntypedSplice NoExtField deco _ expr -> p_hsSpliceTH False expr deco- HsQuasiQuote NoExtField _ quoterName srcSpan str -> do+ HsTypedSplice _ deco _ expr -> p_hsSpliceTH True expr deco+ HsUntypedSplice _ deco _ expr -> p_hsSpliceTH False expr deco+ HsQuasiQuote _ _ quoterName _ str -> do txt "["- p_rdrName (L srcSpan quoterName)+ p_rdrName (noLocA quoterName) txt "|" -- QuasiQuoters often rely on precise custom strings. We cannot do any -- formatting here without potentially breaking someone's code.@@ -1096,34 +1130,21 @@ where decoSymbol = if isTyped then "$$" else "$" -p_hsBracket :: HsBracket GhcPs -> R ()-p_hsBracket = \case- ExpBr NoExtField expr -> do- anns <- getEnclosingAnns- let name = case anns of- AnnOpenEQ : _ -> ""- _ -> "e"+p_hsBracket :: EpAnn [AddEpAnn] -> HsBracket GhcPs -> R ()+p_hsBracket epAnn = \case+ ExpBr _ expr -> do+ let name+ | or [True | AddEpAnn AnnOpenEQ _ <- epAnnAnns epAnn] = ""+ | otherwise = "e" quote name (located expr p_hsExpr)- PatBr NoExtField pat -> located pat (quote "p" . p_pat)- DecBrL NoExtField decls -> quote "d" (handleStarIsType decls (p_hsDecls Free decls))- DecBrG NoExtField _ -> notImplemented "DecBrG" -- result of renamer- TypBr NoExtField ty -> quote "t" (located ty (handleStarIsType ty . p_hsType))- VarBr NoExtField isSingleQuote name -> do+ PatBr _ pat -> located pat (quote "p" . p_pat)+ DecBrL _ decls -> quote "d" (handleStarIsType decls (p_hsDecls Free decls))+ DecBrG _ _ -> notImplemented "DecBrG" -- result of renamer+ TypBr _ ty -> quote "t" (located ty (handleStarIsType ty . p_hsType))+ VarBr _ isSingleQuote name -> do txt (bool "''" "'" isSingleQuote)- -- HACK As you can see we use 'noLoc' here to be able to pass name into- -- 'p_rdrName' since the latter expects a "located" thing. The problem- -- is that 'VarBr' doesn't provide us with location of the name. This in- -- turn makes it impossible to detect if there are parentheses around- -- it, etc. So we have to add parentheses manually assuming they are- -- necessary for all operators.- let isOperator =- all- (\i -> isPunctuation i || isSymbol i)- (showOutputable (rdrNameOcc name))- && not (doesNotNeedExtraParens name)- wrapper = if isOperator then parens N else id- wrapper $ p_rdrName (noLoc name)- TExpBr NoExtField expr -> do+ p_rdrName name+ TExpBr _ expr -> do txt "[||" breakpoint' located expr p_hsExpr@@ -1219,9 +1240,9 @@ liftAppend (x : xs) [] = x : xs liftAppend (x : xs) (y : ys) = x <> y : liftAppend xs ys -getGRHSSpan :: GRHS GhcPs (Located body) -> SrcSpan-getGRHSSpan (GRHS NoExtField guards body) =- combineSrcSpans' $ getLoc body :| map getLoc guards+getGRHSSpan :: GRHS GhcPs (LocatedA body) -> SrcSpan+getGRHSSpan (GRHS _ guards body) =+ combineSrcSpans' $ getLocA body :| map getLocA guards -- | Place a thing that may have a hanging form. This function handles how -- to separate it from preceding expressions and whether to bump indentation@@ -1240,63 +1261,62 @@ -- form. blockPlacement :: (body -> Placement) ->- [LGRHS GhcPs (Located body)] ->+ [LGRHS GhcPs (LocatedA body)] -> Placement-blockPlacement placer [L _ (GRHS NoExtField _ (L _ x))] = placer x+blockPlacement placer [L _ (GRHS _ _ (L _ x))] = placer x blockPlacement _ _ = Normal -- | Check if given command has a hanging form. cmdPlacement :: HsCmd GhcPs -> Placement cmdPlacement = \case- HsCmdLam NoExtField _ -> Hanging- HsCmdCase NoExtField _ _ -> Hanging- HsCmdLamCase NoExtField _ -> Hanging- HsCmdDo NoExtField _ -> Hanging+ HsCmdLam _ _ -> Hanging+ HsCmdCase _ _ _ -> Hanging+ HsCmdLamCase _ _ -> Hanging+ HsCmdDo _ _ -> Hanging _ -> Normal cmdTopPlacement :: HsCmdTop GhcPs -> Placement-cmdTopPlacement (HsCmdTop NoExtField (L _ x)) = cmdPlacement x+cmdTopPlacement (HsCmdTop _ (L _ x)) = cmdPlacement x -- | Check if given expression has a hanging form. exprPlacement :: HsExpr GhcPs -> Placement exprPlacement = \case -- Only hang lambdas with single line parameter lists- HsLam NoExtField mg -> case mg of- MG _ (L _ [L _ (Match NoExtField _ (x : xs) _)]) _- | isOneLineSpan (combineSrcSpans' $ fmap getLoc (x :| xs)) ->- Hanging+ HsLam _ mg -> case mg of+ MG _ (L _ [L _ (Match _ _ (x : xs) _)]) _+ | isOneLineSpan (combineSrcSpans' $ fmap getLocA (x :| xs)) ->+ Hanging _ -> Normal- HsLamCase NoExtField _ -> Hanging- HsCase NoExtField _ _ -> Hanging- HsDo NoExtField (DoExpr _) _ -> Hanging- HsDo NoExtField (MDoExpr _) _ -> Hanging- OpApp NoExtField _ op y ->+ HsLamCase _ _ -> Hanging+ HsCase _ _ _ -> Hanging+ HsDo _ (DoExpr _) _ -> Hanging+ HsDo _ (MDoExpr _) _ -> Hanging+ OpApp _ _ op y -> case (fmap getOpNameStr . getOpName . unLoc) op of Just "$" -> exprPlacement (unLoc y) _ -> Normal- HsApp NoExtField _ y -> exprPlacement (unLoc y)- HsProc NoExtField p _ ->+ HsApp _ _ y -> exprPlacement (unLoc y)+ HsProc _ p _ -> -- Indentation breaks if pattern is longer than one line and left -- hanging. Consequently, only apply hanging when it is safe.- if isOneLineSpan (getLoc p)+ if isOneLineSpan (getLocA p) then Hanging else Normal _ -> Normal -withGuards :: [LGRHS GhcPs (Located body)] -> Bool+withGuards :: [LGRHS GhcPs body] -> Bool withGuards = any (checkOne . unLoc) where- checkOne :: GRHS GhcPs (Located body) -> Bool- checkOne (GRHS NoExtField [] _) = False+ checkOne (GRHS _ [] _) = False checkOne _ = True exprOpTree :: LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)-exprOpTree (L _ (OpApp NoExtField x op y)) = OpBranch (exprOpTree x) op (exprOpTree y)+exprOpTree (L _ (OpApp _ x op y)) = OpBranch (exprOpTree x) op (exprOpTree y) exprOpTree n = OpNode n getOpName :: HsExpr GhcPs -> Maybe RdrName getOpName = \case- HsVar NoExtField (L _ a) -> Just a+ HsVar _ (L _ a) -> Just a _ -> Nothing getOpNameStr :: RdrName -> String@@ -1313,64 +1333,53 @@ -- Distinguish holes used in infix notation. -- eg. '1 _foo 2' and '1 `_foo` 2' opWrapper = case unLoc op of- HsUnboundVar NoExtField _ -> backticks+ HsUnboundVar _ _ -> backticks _ -> id ub <- opBranchBraceStyle placement let opNameStr = (fmap getOpNameStr . getOpName . unLoc) op gotDollar = opNameStr == Just "$" gotColon = opNameStr == Just ":"- gotRecordDot = isRecordDot (unLoc op) (opTreeLoc y) lhs = switchLayout [opTreeLoc x] $ p_exprOpTree s x p_op = located op (opWrapper . p_hsExpr) p_y = switchLayout [opTreeLoc y] (p_exprOpTree N y)- isSection = case (opTreeLoc x, getLoc op) of- (RealSrcSpan treeSpan _, RealSrcSpan opSpan _) ->- srcSpanEndCol treeSpan /= srcSpanStartCol opSpan- _ -> False isDoBlock = \case OpNode (L _ HsDo {}) -> True _ -> False- useRecordDot' <- useRecordDot if | gotColon -> do- ub lhs- space- p_op- case placement of- Hanging -> do- space- p_y- Normal -> do- breakpoint- inciIf (isDoBlock y) p_y+ ub lhs+ space+ p_op+ case placement of+ Hanging -> do+ space+ p_y+ Normal -> do+ breakpoint+ inciIf (isDoBlock y) p_y | gotDollar && isOneLineSpan (opTreeLoc x) && placement == Normal -> do- useBraces lhs- space- p_op- breakpoint- inci p_y- | useRecordDot' && gotRecordDot -> do- lhs- when isSection space- p_op- p_y- | otherwise -> do- ub lhs- placeHanging placement $ do- p_op+ useBraces lhs space- p_y+ p_op+ breakpoint+ inci p_y+ | otherwise -> do+ ub lhs+ placeHanging placement $ do+ p_op+ space+ p_y pattern CmdTopCmd :: HsCmd GhcPs -> LHsCmdTop GhcPs-pattern CmdTopCmd cmd <- (L _ (HsCmdTop NoExtField (L _ cmd)))+pattern CmdTopCmd cmd <- (L _ (HsCmdTop _ (L _ cmd))) cmdOpTree :: LHsCmdTop GhcPs -> OpTree (LHsCmdTop GhcPs) (LHsExpr GhcPs) cmdOpTree = \case- CmdTopCmd (HsCmdArrForm NoExtField op Infix _ [x, y]) ->+ CmdTopCmd (HsCmdArrForm _ op Infix _ [x, y]) -> OpBranch (cmdOpTree x) op (cmdOpTree y) n -> OpNode n @@ -1387,12 +1396,13 @@ p_cmdOpTree y opBranchPlacement ::+ HasSrcSpan l => -- | Placement of nodes (ty -> Placement) -> -- | Left branch- OpTree (Located ty) op ->+ OpTree (GenLocated l ty) op -> -- | Right branch- OpTree (Located ty) op ->+ OpTree (GenLocated l ty) op -> Placement opBranchPlacement f x y -- If the beginning of the first argument and the second argument are on@@ -1400,7 +1410,7 @@ -- placement. | isOneLineSpan (mkSrcSpan (srcSpanStart (opTreeLoc x)) (srcSpanStart (opTreeLoc y))), OpNode (L _ n) <- y =- f n+ f n | otherwise = Normal opBranchBraceStyle :: Placement -> R (R () -> R ())@@ -1410,24 +1420,3 @@ MultiLine -> case placement of Hanging -> useBraces Normal -> dontUseBraces---- | Return 'True' if given expression is a record-dot operator expression.-isRecordDot ::- -- | Operator expression- HsExpr GhcPs ->- -- | Span of the expression on the right-hand side of the operator- SrcSpan ->- Bool-isRecordDot op (RealSrcSpan ySpan _) = case op of- HsVar NoExtField (L (RealSrcSpan opSpan _) opName) ->- (getOpNameStr opName == ".") && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)- _ -> False-isRecordDot _ _ = False---- | Get annotations for the enclosing element.-getEnclosingAnns :: R [AnnKeywordId]-getEnclosingAnns = do- e <- getEnclosingSpan (const True)- case e of- Nothing -> return []- Just e' -> getAnns (RealSrcSpan e' Nothing)
src/Ormolu/Printer/Meat/Declaration/Warning.hs view
@@ -9,20 +9,20 @@ import Data.Foldable import Data.Text (Text)-import GHC.Hs.Decls-import GHC.Hs.Extension-import GHC.Types.Basic+import GHC.Hs import GHC.Types.Name.Reader+import GHC.Types.SourceText import GHC.Types.SrcLoc+import GHC.Unit.Module.Warnings import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common p_warnDecls :: WarnDecls GhcPs -> R ()-p_warnDecls (Warnings NoExtField _ warnings) =+p_warnDecls (Warnings _ _ warnings) = traverse_ (located' p_warnDecl) warnings p_warnDecl :: WarnDecl GhcPs -> R ()-p_warnDecl (Warning NoExtField functions warningTxt) =+p_warnDecl (Warning _ functions warningTxt) = p_topLevelWarning functions warningTxt p_moduleWarning :: WarningTxt -> R ()@@ -30,10 +30,10 @@ let (pragmaText, lits) = warningText wtxt inci $ pragma pragmaText $ inci $ p_lits lits -p_topLevelWarning :: [Located RdrName] -> WarningTxt -> R ()+p_topLevelWarning :: [LocatedN RdrName] -> WarningTxt -> R () p_topLevelWarning fnames wtxt = do let (pragmaText, lits) = warningText wtxt- switchLayout (fmap getLoc fnames ++ fmap getLoc lits) $+ switchLayout (fmap getLocA fnames ++ fmap getLoc lits) $ pragma pragmaText . inci $ do sep commaDel p_rdrName fnames breakpoint
src/Ormolu/Printer/Meat/ImportExport.hs view
@@ -10,8 +10,7 @@ where import Control.Monad-import GHC.Hs.Extension-import GHC.Hs.ImpExp+import GHC.Hs import GHC.LanguageExtensions.Type import GHC.Types.SrcLoc import GHC.Unit.Types@@ -83,15 +82,15 @@ IEVar NoExtField l1 -> do located l1 p_ieWrappedName p_comma- IEThingAbs NoExtField l1 -> do+ IEThingAbs _ l1 -> do located l1 p_ieWrappedName p_comma- IEThingAll NoExtField l1 -> do+ IEThingAll _ l1 -> do located l1 p_ieWrappedName space txt "(..)" p_comma- IEThingWith NoExtField l1 w xs _ -> sitcc $ do+ IEThingWith _ l1 w xs -> sitcc $ do located l1 p_ieWrappedName breakpoint inci $ do@@ -104,7 +103,7 @@ let (before, after) = splitAt n names in before ++ [txt ".."] ++ after p_comma- IEModuleContents NoExtField l1 -> do+ IEModuleContents _ l1 -> do located l1 p_hsmodName p_comma IEGroup NoExtField n str -> do
src/Ormolu/Printer/Meat/Module.hs view
@@ -9,9 +9,8 @@ where import Control.Monad-import GHC.Hs+import GHC.Hs hiding (comment) import GHC.Types.SrcLoc-import Ormolu.Imports (normalizeImports) import Ormolu.Parser.CommentStream import Ormolu.Parser.Pragma import Ormolu.Printer.Combinators@@ -22,7 +21,8 @@ import Ormolu.Printer.Meat.ImportExport import Ormolu.Printer.Meat.Pragma --- | Render a module.+-- | Render a module-like entity (either a regular module or a backpack+-- signature). p_hsModule :: -- | Stack header Maybe (RealLocated Comment) ->@@ -32,8 +32,8 @@ HsModule -> R () p_hsModule mstackHeader pragmas HsModule {..} = do- let deprecSpan = maybe [] (\(L s _) -> [s]) hsmodDeprecMessage- exportSpans = maybe [] (\(L s _) -> [s]) hsmodExports+ let deprecSpan = maybe [] (pure . getLocA) hsmodDeprecMessage+ exportSpans = maybe [] (pure . getLocA) hsmodExports switchLayout (deprecSpan <> exportSpans) $ do forM_ mstackHeader $ \(L spn comment) -> do spitCommentNow spn comment@@ -60,9 +60,9 @@ txt "where" newline newline- forM_ (normalizeImports hsmodImports) (located' p_hsmodImport)+ forM_ hsmodImports (located' p_hsmodImport) newline- switchLayout (getLoc <$> hsmodDecls) $ do+ switchLayout (getLocA <$> hsmodDecls) $ do p_hsDecls Free hsmodDecls newline spitRemainingComments
src/Ormolu/Printer/Meat/Type.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-} -- | Rendering of types. module Ormolu.Printer.Meat.Type@@ -14,17 +15,18 @@ p_forallBndrs, p_conDeclFields, p_lhsTypeArg,- tyVarsToTypes,+ p_hsSigType, tyVarsToTyPats,+ hsOuterTyVarBndrsToHsType,+ lhsTypeToSigType, ) where -import Data.Data (Data)-import GHC.Hs.Decls-import GHC.Hs.Extension-import GHC.Hs.Type+import Data.Foldable (for_)+import GHC.Hs import GHC.Types.Basic hiding (isPromoted) import GHC.Types.Name.Reader+import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Types.Var import Ormolu.Printer.Combinators@@ -46,22 +48,23 @@ p_hsType' :: Bool -> TypeDocStyle -> HsType GhcPs -> R () p_hsType' multilineArgs docStyle = \case- HsForAllTy NoExtField tele t -> do+ HsForAllTy _ tele t -> do case tele of- HsForAllInvis NoExtField bndrs -> p_forallBndrs ForAllInvis p_hsTyVarBndr bndrs- HsForAllVis NoExtField bndrs -> p_forallBndrs ForAllVis p_hsTyVarBndr bndrs+ HsForAllInvis _ bndrs -> p_forallBndrs ForAllInvis p_hsTyVarBndr bndrs+ HsForAllVis _ bndrs -> p_forallBndrs ForAllVis p_hsTyVarBndr bndrs interArgBreak p_hsTypeR (unLoc t)- HsQualTy NoExtField qs t -> do- located qs p_hsContext- space- txt "=>"- interArgBreak+ HsQualTy _ qs' t -> do+ for_ qs' $ \qs -> do+ located qs p_hsContext+ space+ txt "=>"+ interArgBreak case unLoc t of HsQualTy {} -> p_hsTypeR (unLoc t) HsFunTy {} -> p_hsTypeR (unLoc t) _ -> located t p_hsTypeR- HsTyVar NoExtField p n -> do+ HsTyVar _ p n -> do case p of IsPromoted -> do txt "'"@@ -70,7 +73,7 @@ _ -> return () NotPromoted -> return () p_rdrName n- HsAppTy NoExtField f x -> do+ HsAppTy _ f x -> do let -- In order to format type applications with multiple parameters -- nicer, traverse the AST to gather the function and all the -- parameters together.@@ -79,7 +82,7 @@ L _ (HsAppTy _ l r) -> gatherArgs l (r : knownArgs) _ -> (f', knownArgs) (func, args) = gatherArgs f [x]- switchLayout (getLoc f : fmap getLoc args) . sitcc $ do+ switchLayout (getLocA f : fmap getLocA args) . sitcc $ do located func p_hsType breakpoint inci $@@ -93,13 +96,13 @@ inci $ do txt "@" located kd p_hsType- HsFunTy NoExtField arrow x y@(L _ y') -> do+ HsFunTy _ arrow x y@(L _ y') -> do located x p_hsType space case arrow of HsUnrestrictedArrow _ -> txt "->"- HsLinearArrow _ -> txt "%1 ->"- HsExplicitMult _ mult -> do+ HsLinearArrow _ _ -> txt "%1 ->"+ HsExplicitMult _ _ mult -> do txt "%" p_hsTypeR (unLoc mult) space@@ -108,40 +111,38 @@ case y' of HsFunTy {} -> p_hsTypeR y' _ -> located y p_hsTypeR- HsListTy NoExtField t ->+ HsListTy _ t -> located t (brackets N . p_hsType)- HsTupleTy NoExtField tsort xs ->+ HsTupleTy _ tsort xs -> let parens' = case tsort of HsUnboxedTuple -> parensHash N- HsBoxedTuple -> parens N- HsConstraintTuple -> parens N HsBoxedOrConstraintTuple -> parens N in parens' $ sep commaDel (sitcc . located' p_hsType) xs- HsSumTy NoExtField xs ->+ HsSumTy _ xs -> parensHash N $ sep (txt "|" >> breakpoint) (sitcc . located' p_hsType) xs- HsOpTy NoExtField x op y ->+ HsOpTy _ x op y -> sitcc $ let opTree = OpBranch (tyOpTree x) op (tyOpTree y) in p_tyOpTree (reassociateOpTree Just opTree)- HsParTy NoExtField t ->+ HsParTy _ t -> parens N (located t p_hsType)- HsIParamTy NoExtField n t -> sitcc $ do+ HsIParamTy _ n t -> sitcc $ do located n atom space txt "::" breakpoint inci (located t p_hsType)- HsStarTy NoExtField _ -> txt "*"- HsKindSig NoExtField t k -> sitcc $ do+ HsStarTy _ _ -> txt "*"+ HsKindSig _ t k -> sitcc $ do located t p_hsType space txt "::" breakpoint inci (located k p_hsType)- HsSpliceTy NoExtField splice -> p_hsSplice splice- HsDocTy NoExtField t str ->+ HsSpliceTy _ splice -> p_hsSplice splice+ HsDocTy _ t str -> case docStyle of PipeStyle -> do p_hsDocString Pipe True str@@ -150,7 +151,7 @@ located t p_hsType newline p_hsDocString Caret False str- HsBangTy NoExtField (HsSrcBang _ u s) t -> do+ HsBangTy _ (HsSrcBang _ u s) t -> do case u of SrcUnpack -> txt "{-# UNPACK #-}" >> space SrcNoUnpack -> txt "{-# NOUNPACK #-}" >> space@@ -160,9 +161,9 @@ SrcStrict -> txt "!" NoSrcStrict -> return () located t p_hsType- HsRecTy NoExtField fields ->+ HsRecTy _ fields -> p_conDeclFields fields- HsExplicitListTy NoExtField p xs -> do+ HsExplicitListTy _ p xs -> do case p of IsPromoted -> txt "'" NotPromoted -> return ()@@ -173,19 +174,19 @@ (IsPromoted, L _ t : _) | isPromoted t -> space _ -> return () sep commaDel (sitcc . located' p_hsType) xs- HsExplicitTupleTy NoExtField xs -> do+ HsExplicitTupleTy _ xs -> do txt "'" parens N $ do case xs of L _ t : _ | isPromoted t -> space _ -> return () sep commaDel (located' p_hsType) xs- HsTyLit NoExtField t ->+ HsTyLit _ t -> case t of HsStrTy (SourceText s) _ -> p_stringLit s a -> atom a- HsWildCardTy NoExtField -> txt "_"- XHsType (NHsCoreTy t) -> atom t+ HsWildCardTy _ -> txt "_"+ XHsType t -> atom t where isPromoted = \case HsAppTy _ (L _ f) _ -> isPromoted f@@ -228,9 +229,9 @@ p_hsTyVarBndr :: IsInferredTyVarBndr flag => HsTyVarBndr flag GhcPs -> R () p_hsTyVarBndr = \case- UserTyVar NoExtField flag x ->+ UserTyVar _ flag x -> (if isInferred flag then braces N else id) $ p_rdrName x- KindedTyVar NoExtField flag l k -> (if isInferred flag then braces else parens) N $ do+ KindedTyVar _ flag l k -> (if isInferred flag then braces else parens) N $ do located l atom space txt "::"@@ -240,11 +241,11 @@ data ForAllVisibility = ForAllInvis | ForAllVis -- | Render several @forall@-ed variables.-p_forallBndrs :: Data a => ForAllVisibility -> (a -> R ()) -> [Located a] -> R ()+p_forallBndrs :: ForAllVisibility -> (a -> R ()) -> [LocatedA a] -> R () p_forallBndrs ForAllInvis _ [] = txt "forall." p_forallBndrs ForAllVis _ [] = txt "forall ->" p_forallBndrs vis p tyvars =- switchLayout (getLoc <$> tyvars) $ do+ switchLayout (getLocA <$> tyvars) $ do txt "forall" breakpoint inci $ do@@ -270,12 +271,12 @@ breakpoint sitcc . inci $ p_hsType (unLoc cd_fld_type) -tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (Located RdrName)-tyOpTree (L _ (HsOpTy NoExtField l op r)) =+tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (LocatedN RdrName)+tyOpTree (L _ (HsOpTy _ l op r)) = OpBranch (tyOpTree l) op (tyOpTree r) tyOpTree n = OpNode n -p_tyOpTree :: OpTree (LHsType GhcPs) (Located RdrName) -> R ()+p_tyOpTree :: OpTree (LHsType GhcPs) (LocatedN RdrName) -> R () p_tyOpTree (OpNode n) = located n p_hsType p_tyOpTree (OpBranch l op r) = do switchLayout [opTreeLoc l] $@@ -295,23 +296,38 @@ -- NOTE(amesgen) is this unreachable or just not implemented? HsArgPar _ -> notImplemented "HsArgPar" +p_hsSigType :: HsSigType GhcPs -> R ()+p_hsSigType HsSig {..} =+ p_hsType $ hsOuterTyVarBndrsToHsType sig_bndrs sig_body+ ---------------------------------------------------------------------------- -- Conversion functions -tyVarsToTypes :: LHsQTyVars GhcPs -> [LHsType GhcPs]-tyVarsToTypes HsQTvs {..} = fmap tyVarToType <$> hsq_explicit- tyVarToType :: HsTyVarBndr () GhcPs -> HsType GhcPs tyVarToType = \case- UserTyVar NoExtField () tvar -> HsTyVar NoExtField NotPromoted tvar- KindedTyVar NoExtField () tvar kind ->+ UserTyVar _ () tvar -> HsTyVar EpAnnNotUsed NotPromoted tvar+ KindedTyVar _ () tvar kind -> -- Note: we always add parentheses because for whatever reason GHC does -- not use HsParTy for left-hand sides of declarations. Please see -- <https://gitlab.haskell.org/ghc/ghc/issues/17404>. This is fine as -- long as 'tyVarToType' does not get applied to right-hand sides of -- declarations.- HsParTy NoExtField . noLoc $- HsKindSig NoExtField (noLoc (HsTyVar NoExtField NotPromoted tvar)) kind+ HsParTy EpAnnNotUsed . noLocA $+ HsKindSig EpAnnNotUsed (noLocA (HsTyVar EpAnnNotUsed NotPromoted tvar)) kind tyVarsToTyPats :: LHsQTyVars GhcPs -> HsTyPats GhcPs tyVarsToTyPats HsQTvs {..} = HsValArg . fmap tyVarToType <$> hsq_explicit++-- could be generalized to also handle () instead of Specificity+hsOuterTyVarBndrsToHsType ::+ HsOuterTyVarBndrs Specificity GhcPs ->+ LHsType GhcPs ->+ HsType GhcPs+hsOuterTyVarBndrsToHsType obndrs ty = case obndrs of+ HsOuterImplicit NoExtField -> unLoc ty+ HsOuterExplicit _ bndrs ->+ HsForAllTy NoExtField (mkHsForAllInvisTele EpAnnNotUsed bndrs) ty++lhsTypeToSigType :: LHsType GhcPs -> LHsSigType GhcPs+lhsTypeToSigType ty =+ reLocA . L (getLocA ty) . HsSig NoExtField (HsOuterImplicit NoExtField) $ ty
src/Ormolu/Printer/Operators.hs view
@@ -15,11 +15,12 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, mapMaybe)-import GHC.Types.Basic+import GHC.Types.Fixity import GHC.Types.Name.Occurrence (occNameString) import GHC.Types.Name.Reader+import GHC.Types.SourceText import GHC.Types.SrcLoc-import Ormolu.Utils (unSrcSpan)+import Ormolu.Utils -- | Intermediate representation of operator trees. It has two type -- parameters: @ty@ is the type of sub-expressions, while @op@ is the type@@ -32,8 +33,8 @@ (OpTree ty op) -- | Return combined 'SrcSpan's of all elements in this 'OpTree'.-opTreeLoc :: OpTree (Located a) b -> SrcSpan-opTreeLoc (OpNode (L l _)) = l+opTreeLoc :: HasSrcSpan l => OpTree (GenLocated l a) b -> SrcSpan+opTreeLoc (OpNode n) = getLoc' n opTreeLoc (OpBranch l _ r) = combineSrcSpans (opTreeLoc l) (opTreeLoc r) -- | Re-associate an 'OpTree' taking into account automagically inferred@@ -41,12 +42,13 @@ -- an initial 'OpTree', then re-associate it using this function before -- printing. reassociateOpTree ::+ (HasSrcSpan l, HasSrcSpan l') => -- | How to get name of an operator (op -> Maybe RdrName) -> -- | Original 'OpTree'- OpTree (Located ty) (Located op) ->+ OpTree (GenLocated l ty) (GenLocated l' op) -> -- | Re-associated 'OpTree'- OpTree (Located ty) (Located op)+ OpTree (GenLocated l ty) (GenLocated l' op) reassociateOpTree getOpName opTree = reassociateOpTreeWith (buildFixityMap getOpName normOpTree)@@ -108,11 +110,12 @@ -- | Build a map of inferred 'Fixity's from an 'OpTree'. buildFixityMap ::- forall ty op.+ forall ty op l l'.+ (HasSrcSpan l, HasSrcSpan l') => -- | How to get the name of an operator (op -> Maybe RdrName) -> -- | Operator tree- OpTree (Located ty) (Located op) ->+ OpTree (GenLocated l ty) (GenLocated l' op) -> -- | Fixity map Map String Fixity buildFixityMap getOpName opTree =@@ -133,16 +136,16 @@ ] `M.union` m fixity = Fixity NoSourceText- score :: OpTree (Located ty) (Located op) -> [(String, Score)]+ score :: OpTree (GenLocated l ty) (GenLocated l' op) -> [(String, Score)] score (OpNode _) = [] score (OpBranch l o r) = fromMaybe (score r) $ do -- If we fail to get any of these, 'defaultFixity' will be used by -- 'reassociateOpTreeWith'.- le <- srcSpanEndLine <$> unSrcSpan (opTreeLoc l) -- left end- ob <- srcSpanStartLine <$> unSrcSpan (getLoc o) -- operator begin- oe <- srcSpanEndLine <$> unSrcSpan (getLoc o) -- operator end- rb <- srcSpanStartLine <$> unSrcSpan (opTreeLoc r) -- right begin- oc <- srcSpanStartCol <$> unSrcSpan (getLoc o) -- operator column+ le <- srcSpanEndLine <$> srcSpanToRealSrcSpan (opTreeLoc l) -- left end+ ob <- srcSpanStartLine <$> srcSpanToRealSrcSpan (getLoc' o) -- operator begin+ oe <- srcSpanEndLine <$> srcSpanToRealSrcSpan (getLoc' o) -- operator end+ rb <- srcSpanStartLine <$> srcSpanToRealSrcSpan (opTreeLoc r) -- right begin+ oc <- srcSpanStartCol <$> srcSpanToRealSrcSpan (getLoc' o) -- operator column opName <- occNameString . rdrNameOcc <$> getOpName (unLoc o) let s | le < ob = AtBeginning oc
src/Ormolu/Printer/SpanStream.hs view
@@ -11,9 +11,11 @@ import Data.DList (DList) import qualified Data.DList as D import Data.Data (Data)-import Data.Generics (everything, ext2Q)+import Data.Generics (everything, ext1Q, ext2Q) import Data.List (sortOn)+import Data.Maybe (maybeToList) import Data.Typeable (cast)+import GHC.Parser.Annotation import GHC.Types.SrcLoc -- | A stream of 'RealSrcSpan's in ascending order. This allows us to tell@@ -33,14 +35,15 @@ SpanStream . sortOn realSrcSpanStart . D.toList- $ everything mappend (const mempty `ext2Q` queryLocated) a+ $ everything mappend (const mempty `ext2Q` queryLocated `ext1Q` querySrcSpanAnn) a where queryLocated :: (Data e0) => GenLocated e0 e1 -> DList RealSrcSpan queryLocated (L mspn _) =- case cast mspn :: Maybe SrcSpan of- Nothing -> mempty- Just (UnhelpfulSpan _) -> mempty- Just (RealSrcSpan spn _) -> D.singleton spn+ maybe mempty srcSpanToRealSrcSpanDList (cast mspn :: Maybe SrcSpan)+ querySrcSpanAnn :: SrcSpanAnn' a -> DList RealSrcSpan+ querySrcSpanAnn = srcSpanToRealSrcSpanDList . locA+ srcSpanToRealSrcSpanDList =+ D.fromList . maybeToList . srcSpanToRealSrcSpan
src/Ormolu/Processing/Common.hs view
@@ -7,7 +7,6 @@ ( removeIndentation, reindent, linesInRegion,- regionInbetween, intSetToRegions, ) where@@ -40,20 +39,6 @@ where (_, nonPrefix) = splitAt regionPrefixLength ls middle = take (length nonPrefix - regionSuffixLength) nonPrefix---- | Get the region after the end of the first and till the end of--- the second region.-regionInbetween ::- -- | Total number of lines- Int ->- RegionDeltas ->- RegionDeltas ->- RegionDeltas-regionInbetween total r r' =- RegionDeltas- { regionPrefixLength = total - regionSuffixLength r,- regionSuffixLength = total - regionPrefixLength r'- } -- | Convert a set of line indices into disjoint 'RegionDelta's intSetToRegions ::
src/Ormolu/Processing/Cpp.hs view
@@ -29,25 +29,25 @@ go _ [] = [] go state ((line, i) : ls) | any for ["define ", "include ", "undef "] =- i : go contState ls+ i : go contState ls | any for ["ifdef ", "ifndef ", "if "] =- let state' = case state of- InConditional nc -> InConditional (nc + 1)- _ -> InConditional 1- in i : go state' ls+ let state' = case state of+ InConditional nc -> InConditional (nc + 1)+ _ -> InConditional 1+ in i : go state' ls | for "endif" =- let state' = case state of- InConditional nc | nc > 1 -> InConditional (nc - 1)- _ -> Outside- in i : go state' ls+ let state' = case state of+ InConditional nc | nc > 1 -> InConditional (nc - 1)+ _ -> Outside+ in i : go state' ls | otherwise =- let is = case state of- Outside -> []- _ -> [i]- state' = case state of- InContinuation -> contState- _ -> state- in is <> go state' ls+ let is = case state of+ Outside -> []+ _ -> [i]+ state' = case state of+ InContinuation -> contState+ _ -> state+ in is <> go state' ls where for directive = isJust $ do s <- dropWhile isSpace <$> L.stripPrefix "#" line
src/Ormolu/Processing/Preprocess.hs view
@@ -10,6 +10,7 @@ where import Control.Monad+import Data.Array as A import Data.Bifunctor (bimap) import Data.Char (isSpace) import Data.Function ((&))@@ -76,13 +77,15 @@ Left r | T.all isSpace r -> True _ -> False - rawLines = lines rawInput+ rawLines = A.listArray (0, length rawLines' - 1) rawLines'+ where+ rawLines' = lines rawInput rawLineLength = length rawLines interleave [] bs = bs interleave (a : as) bs = a : interleave bs as - xs !!? i = if i >= 0 && i < length xs then Just $ xs !! i else Nothing+ xs !!? i = if A.bounds rawLines `A.inRange` i then Just $ xs A.! i else Nothing -- | All lines we are not supposed to format, and a set of replacements -- for specific lines.@@ -124,10 +127,10 @@ go state ((line, i) : ls) | isMagicComment ormoluDisable line, state == OrmoluEnabled =- ([i], [(i, magicComment ormoluDisable)]) : go OrmoluDisabled ls+ ([i], [(i, magicComment ormoluDisable)]) : go OrmoluDisabled ls | isMagicComment ormoluEnable line, state == OrmoluDisabled =- ([i], [(i, magicComment ormoluEnable)]) : go OrmoluEnabled ls+ ([i], [(i, magicComment ormoluEnable)]) : go OrmoluEnabled ls | otherwise = iIfDisabled : go state ls where iIfDisabled = case state of
src/Ormolu/Utils.hs view
@@ -10,11 +10,12 @@ notImplemented, showOutputable, splitDocString,- unSrcSpan, incSpanLine, separatedByBlank, separatedByBlankNE, onTheSameLine,+ HasSrcSpan (..),+ getLoc', ) where @@ -24,10 +25,11 @@ import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T+import GHC.Driver.Ppr import GHC.DynFlags (baseDynFlags) import GHC.Hs import GHC.Types.SrcLoc-import qualified GHC.Utils.Outputable as GHC+import GHC.Utils.Outputable -- | Relative positions in a list. data RelativePos@@ -57,8 +59,8 @@ notImplemented msg = error $ "not implemented yet: " ++ msg -- | Pretty-print an 'GHC.Outputable' thing.-showOutputable :: GHC.Outputable o => o -> String-showOutputable = GHC.showSDoc baseDynFlags . GHC.ppr+showOutputable :: Outputable o => o -> String+showOutputable = showSDoc baseDynFlags . ppr -- | Split and normalize a doc string. The result is a list of lines that -- make up the comment.@@ -97,12 +99,6 @@ then dropSpace <$> xs else xs --- | Get 'RealSrcSpan' out of 'SrcSpan' if the span is “helpful”.-unSrcSpan :: SrcSpan -> Maybe RealSrcSpan-unSrcSpan = \case- RealSrcSpan r _ -> Just r- UnhelpfulSpan _ -> Nothing- -- | Increment line number in a 'SrcSpan'. incSpanLine :: Int -> SrcSpan -> SrcSpan incSpanLine i = \case@@ -121,8 +117,8 @@ separatedByBlank :: (a -> SrcSpan) -> a -> a -> Bool separatedByBlank loc a b = fromMaybe False $ do- endA <- srcSpanEndLine <$> unSrcSpan (loc a)- startB <- srcSpanStartLine <$> unSrcSpan (loc b)+ endA <- srcSpanEndLine <$> srcSpanToRealSrcSpan (loc a)+ startB <- srcSpanStartLine <$> srcSpanToRealSrcSpan (loc b) pure (startB - endA >= 2) -- | Do two declaration groups have a blank between them?@@ -133,3 +129,15 @@ onTheSameLine :: SrcSpan -> SrcSpan -> Bool onTheSameLine a b = isOneLineSpan (mkSrcSpan (srcSpanEnd a) (srcSpanStart b))++class HasSrcSpan l where+ loc' :: l -> SrcSpan++instance HasSrcSpan SrcSpan where+ loc' = id++instance HasSrcSpan (SrcSpanAnn' ann) where+ loc' = locA++getLoc' :: HasSrcSpan l => GenLocated l a -> SrcSpan+getLoc' = loc' . getLoc
src/Ormolu/Utils/Extensions.hs view
@@ -21,6 +21,7 @@ import Distribution.PackageDescription import Distribution.PackageDescription.Parsec import qualified Distribution.Types.CondTree as CT+import Distribution.Utils.Path (getSymbolicPath) import Language.Haskell.Extension import Ormolu.Config import Ormolu.Exception@@ -60,13 +61,12 @@ where prependSrcDirs f | null hsSourceDirs = [f]- | otherwise = (</> f) <$> hsSourceDirs+ | otherwise = (</> f) . getSymbolicPath <$> hsSourceDirs exts = maybe [] langExt defaultLanguage ++ fmap extToDynOption defaultExtensions langExt =- pure . DynOption . \case- Haskell98 -> "-XHaskell98"- Haskell2010 -> "-XHaskell2010"- UnknownLanguage lan -> "-X" ++ lan+ pure . DynOption . ("-X" <>) . \case+ UnknownLanguage lan -> lan+ lan -> show lan extToDynOption = DynOption . \case EnableExtension e -> "-X" ++ show e@@ -108,9 +108,9 @@ [] -> pure Nothing e : es | takeExtension e == ".cabal" ->- doesFileExist (parentDir </> e) >>= \case- True -> pure $ Just e- False -> findDotCabal es+ doesFileExist (parentDir </> e) >>= \case+ True -> pure $ Just e+ False -> findDotCabal es _ : es -> findDotCabal es findDotCabal dirEntries >>= \case Just cabalFile -> pure . Just $ parentDir </> cabalFile
tests/Ormolu/Diff/TextSpec.hs view
@@ -25,7 +25,7 @@ stdTest "trimming" "spaced" "spaced-v2" stdTest "trailing-blank-line" "no-trailing-blank-line" "with-trailing-blank-line" --- | Test diff printig.+-- | Test diff printing. stdTest :: -- | Name of the test case String ->@@ -45,7 +45,7 @@ expectedDiffText <- parseRelFile expectedDiffPath >>= readFileUtf8 . toFilePath . (diffOutputsDir </>)- let Just actualDiff = diffText inputA inputB "TEST"+ Just actualDiff <- pure $ diffText inputA inputB "TEST" actualDiffText <- printDiff actualDiff actualDiffText `shouldBe` expectedDiffText
tests/Ormolu/PrinterSpec.hs view
@@ -5,13 +5,17 @@ import Control.Exception import Control.Monad import Data.List (isSuffixOf)+import Data.Maybe (isJust) import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.IO as T import Ormolu import Ormolu.Utils.IO import Path import Path.IO+import System.Environment (lookupEnv) import qualified System.FilePath as F+import System.IO.Unsafe (unsafePerformIO) import Test.Hspec spec :: Spec@@ -23,20 +27,26 @@ checkExample :: Path Rel File -> Spec checkExample srcPath' = it (fromRelFile srcPath' ++ " works") . withNiceExceptions $ do let srcPath = examplesDir </> srcPath'+ inputPath = fromRelFile srcPath+ config =+ defaultConfig+ { cfgSourceType = detectSourceType inputPath+ } expectedOutputPath <- deriveOutput srcPath -- 1. Given input snippet of source code parse it and pretty print it. -- 2. Parse the result of pretty-printing again and make sure that AST -- is the same as AST of the original snippet. (This happens in -- 'ormoluFile' automatically.)- formatted0 <- ormoluFile defaultConfig (fromRelFile srcPath)+ formatted0 <- ormoluFile config inputPath -- 3. Check the output against expected output. Thus all tests should -- include two files: input and expected output.- -- T.writeFile (fromRelFile expectedOutputPath) formatted0+ when shouldRegenerateOutput $+ T.writeFile (fromRelFile expectedOutputPath) formatted0 expected <- readFileUtf8 $ fromRelFile expectedOutputPath shouldMatch False formatted0 expected -- 4. Check that running the formatter on the output produces the same -- output again (the transformation is idempotent).- formatted1 <- ormolu defaultConfig "<formatted>" (T.unpack formatted0)+ formatted1 <- ormolu config "<formatted>" (T.unpack formatted0) shouldMatch True formatted1 formatted0 -- | Build list of examples for testing.@@ -50,13 +60,15 @@ isInput path = let s = fromRelFile path (s', exts) = F.splitExtensions s- in exts == ".hs" && not ("-out" `isSuffixOf` s')+ in exts `elem` [".hs", ".hsig"] && not ("-out" `isSuffixOf` s') -- | For given path of input file return expected name of output. deriveOutput :: Path Rel File -> IO (Path Rel File) deriveOutput path = parseRelFile $- F.addExtension (F.dropExtensions (fromRelFile path) ++ "-out") "hs"+ F.addExtension (radical ++ "-out") exts+ where+ (radical, exts) = F.splitExtensions (fromRelFile path) -- | A version of 'shouldBe' that is specialized to comparing 'Text' values. -- It also prints multi-line snippets in a more readable form.@@ -88,3 +100,8 @@ where h :: OrmoluException -> IO () h = expectationFailure . displayException++shouldRegenerateOutput :: Bool+shouldRegenerateOutput =+ unsafePerformIO $ isJust <$> lookupEnv "ORMOLU_REGENERATE_EXAMPLES"+{-# NOINLINE shouldRegenerateOutput #-}