ormolu 0.0.3.1 → 0.0.4.0
raw patch · 76 files changed
+1056/−886 lines, 76 filesdep ~ghc-lib-parser
Dependency ranges changed: ghc-lib-parser
Files
- CHANGELOG.md +34/−0
- README.md +4/−1
- app/Main.hs +113/−89
- data/examples/declaration/class/dependency-super-classes-out.hs +2/−1
- data/examples/declaration/class/functional-dependencies-out.hs +2/−1
- data/examples/declaration/class/multi-parameters2-out.hs +2/−1
- data/examples/declaration/data/existential-multiline-out.hs +12/−0
- data/examples/declaration/data/existential-multiline.hs +7/−0
- data/examples/declaration/data/gadt/multiline-where-out.hs +7/−0
- data/examples/declaration/data/gadt/multiline-where.hs +6/−0
- data/examples/declaration/data/record-multi-const-out.hs +17/−0
- data/examples/declaration/data/record-multi-const.hs +13/−0
- data/examples/declaration/data/record-out.hs +19/−20
- data/examples/declaration/data/simple-broken-out.hs +1/−2
- data/examples/declaration/instance/data-family-instances-gadt-out.hs +4/−2
- data/examples/declaration/instance/data-family-instances-newtype-out.hs +3/−4
- data/examples/declaration/type-families/closed-type-family/multi-line-out.hs +6/−5
- data/examples/declaration/type/visible-forall-out.hs +2/−0
- data/examples/declaration/type/visible-forall.hs +2/−0
- data/examples/declaration/value/function/arrow/expression-applications-out.hs +0/−9
- data/examples/declaration/value/function/arrow/expression-applications.hs +0/−9
- data/examples/declaration/value/function/arrow/expression-forms-out.hs +0/−14
- data/examples/declaration/value/function/arrow/expression-forms.hs +0/−11
- data/examples/declaration/value/function/arrow/multiline-case-out.hs +8/−0
- data/examples/declaration/value/function/arrow/multiline-case.hs +7/−0
- data/examples/declaration/value/function/arrow/proc-applications-out.hs +6/−5
- data/examples/declaration/value/function/arrow/proc-do-complex-out.hs +17/−13
- data/examples/declaration/value/function/arrow/proc-do-simple1-out.hs +3/−2
- data/examples/declaration/value/function/arrow/proc-do-simple2-out.hs +9/−7
- data/examples/declaration/value/function/arrow/proc-forms1-out.hs +8/−6
- data/examples/declaration/value/function/arrow/proc-forms2-out.hs +10/−6
- data/examples/declaration/value/function/arrow/proc-forms2.hs +6/−6
- data/examples/declaration/value/function/arrow/proc-ifs-out.hs +6/−4
- data/examples/declaration/value/function/arrow/proc-parentheses-out.hs +5/−4
- data/examples/declaration/value/function/arrow/recursive-procs-out.hs +14/−10
- data/examples/declaration/value/function/pattern/famous-cardano-pattern-out.hs +8/−8
- data/examples/declaration/value/function/pattern/multiline-case-pattern-out.hs +2/−2
- data/examples/declaration/value/function/pattern/view-pattern-out.hs +0/−3
- data/examples/declaration/value/function/pattern/view-pattern.hs +0/−3
- data/examples/import/qualified-post-out.hs +5/−0
- data/examples/import/qualified-post.hs +5/−0
- data/examples/import/qualified-prelude-out.hs +1/−1
- data/examples/other/multiline-forall-out.hs +1/−2
- ormolu.cabal +5/−7
- src/GHC.hs +2/−10
- src/GHC/DynFlags.hs +30/−19
- src/Ormolu/Config.hs +17/−19
- src/Ormolu/Diff.hs +8/−1
- src/Ormolu/Imports.hs +14/−14
- src/Ormolu/Parser.hs +57/−15
- src/Ormolu/Parser/Pragma.hs +4/−4
- src/Ormolu/Parser/Result.hs +16/−15
- src/Ormolu/Printer.hs +6/−1
- src/Ormolu/Printer/Combinators.hs +0/−24
- src/Ormolu/Printer/Internal.hs +35/−37
- src/Ormolu/Printer/Meat/Common.hs +0/−1
- src/Ormolu/Printer/Meat/Declaration.hs +69/−60
- src/Ormolu/Printer/Meat/Declaration/Annotation.hs +2/−3
- src/Ormolu/Printer/Meat/Declaration/Class.hs +19/−27
- src/Ormolu/Printer/Meat/Declaration/Data.hs +48/−26
- src/Ormolu/Printer/Meat/Declaration/Default.hs +2/−3
- src/Ormolu/Printer/Meat/Declaration/Foreign.hs +2/−3
- src/Ormolu/Printer/Meat/Declaration/Instance.hs +8/−8
- src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs +2/−5
- src/Ormolu/Printer/Meat/Declaration/Rule.hs +10/−11
- src/Ormolu/Printer/Meat/Declaration/Signature.hs +29/−15
- src/Ormolu/Printer/Meat/Declaration/Splice.hs +2/−3
- src/Ormolu/Printer/Meat/Declaration/Type.hs +1/−4
- src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs +17/−18
- src/Ormolu/Printer/Meat/Declaration/Value.hs +184/−207
- src/Ormolu/Printer/Meat/Declaration/Warning.hs +4/−5
- src/Ormolu/Printer/Meat/ImportExport.hs +18/−15
- src/Ormolu/Printer/Meat/Module.hs +5/−2
- src/Ormolu/Printer/Meat/Type.hs +53/−40
- src/Ormolu/Printer/Operators.hs +8/−11
- src/Ormolu/Utils.hs +2/−2
CHANGELOG.md view
@@ -1,3 +1,37 @@+## Ormolu 0.0.4.0++* When given several files to format, Ormolu does not stop on the first+ failure, but tries to format all the files. [Issue+ 502](https://github.com/tweag/ormolu/issues/502).++* Made rendering of pattern matches involving operators consistent with+ other cases of rendering of operators. [Issue+ 500](https://github.com/tweag/ormolu/issues/500).++* More compact rendering of type family injectivity constraints. [Issue+ 482](https://github.com/tweag/ormolu/issues/482).++* Improved rendering of the keyword `where` in class, data, and type family+ declarations. When headers of these declarations are multi-line `where` is+ now put on its own line. [Issue+ 509](https://github.com/tweag/ormolu/issues/509).++* Fixed the bug pertaining to rendering of arrow notation with multiline+ expressions. [Issue 513](https://github.com/tweag/ormolu/issues/513).++* Made rendering of data type definitions, value-level applications, and+ application of types use the same style. Moreover, existential now doesn't+ cause the data constructor be unconditionally rendered in multiline+ layout. [Issue 427](https://github.com/tweag/ormolu/issues/427).++* Records with a single data constructor are now formatted more compactly.+ [Issue 425](https://github.com/tweag/ormolu/issues/425).++* Switched to `ghc-lib-parser-8.10.1`.++* Implemented support for the new language extensions `ImportQualifiedPost`+ and `StandaloneKindSignatures`.+ ## Ormolu 0.0.3.1 * Fixed rendering of record updates with the record dot preprocessor syntax
README.md view
@@ -4,7 +4,7 @@ [](https://hackage.haskell.org/package/ormolu) [](http://stackage.org/nightly/package/ormolu) [](http://stackage.org/lts/package/ormolu)-[](https://circleci.com/gh/tweag/ormolu/tree/master)+[](https://buildkite.com/tweag-1/ormolu) Ormolu is a formatter for Haskell source code. The project was created with the following goals in mind:@@ -104,6 +104,7 @@ * [Emacs][emacs-package] * [VS Code][vs-code-plugin]+* vim: [neoformat][neoformat], [vim-ormolu][vim-ormolu] ## Running on Hackage @@ -135,3 +136,5 @@ [haskell-src-exts]: https://hackage.haskell.org/package/haskell-src-exts [emacs-package]: https://github.com/vyorkin/ormolu.el [vs-code-plugin]: https://marketplace.visualstudio.com/items?itemName=sjurmillidahl.ormolu-vscode+[vim-ormolu]: https://github.com/sdiehl/vim-ormolu+[neoformat]: https://github.com/sbdchd/neoformat
app/Main.hs view
@@ -1,12 +1,19 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} -module Main (main) where+module Main+ ( main,+ )+where +import Control.Exception (SomeException, displayException, try) import Control.Monad+import Data.Either (lefts) import Data.List (intercalate, sort)+import qualified Data.Text.IO as TIO import Data.Version (showVersion) import Development.GitRev import Options.Applicative@@ -16,10 +23,8 @@ import Paths_ormolu (version) import System.Exit (ExitCode (..), exitWith) import System.IO (hPutStrLn, stderr)-import qualified Data.Text.IO as TIO -- | Entry point of the program.- main :: IO () main = withPrettyOrmoluExceptions $ do Opts {..} <- execParser optsParserInfo@@ -27,24 +32,35 @@ case optInputFiles of [] -> formatOne' Nothing ["-"] -> formatOne' Nothing- xs -> mapM_ (formatOne' . Just) xs+ [x] -> formatOne' (Just x)+ xs -> do+ -- It is possible to get IOException, error's and 'OrmoluException's+ -- from 'formatOne', so we just catch everything.+ errs <-+ lefts <$> mapM (try @SomeException . formatOne' . Just) (sort xs)+ unless (null errs) $ do+ mapM_ (hPutStrLn stderr . displayException) errs+ exitWith (ExitFailure 102) -- | Format a single input.--formatOne- :: Mode -- ^ Mode of operation- -> Config -- ^ Configuration- -> Maybe FilePath -- ^ File to format or stdin as 'Nothing'- -> IO ()+formatOne ::+ -- | Mode of operation+ Mode ->+ -- | Configuration+ Config ->+ -- | File to format or stdin as 'Nothing'+ Maybe FilePath ->+ IO () formatOne mode config = \case Nothing -> do r <- ormoluStdin config case mode of Stdout -> TIO.putStr r- _ -> do- hPutStrLn stderr+ _ -> do+ hPutStrLn+ stderr "This feature is not supported when input comes from stdin."- -- 101 is different from all the other exit codes we already use.+ -- 101 is different from all the other exit codes we already use. exitWith (ExitFailure 101) Just inputFile -> do r <- ormoluFile config inputFile@@ -65,101 +81,109 @@ -- Command line options parsing. data Opts = Opts- { optMode :: !Mode- -- ^ Mode of operation- , optConfig :: !Config- -- ^ Ormolu 'Config'- , optInputFiles :: ![FilePath]- -- ^ Haskell source files to format or stdin (when the list is empty)+ { -- | Mode of operation+ optMode :: !Mode,+ -- | Ormolu 'Config'+ optConfig :: !Config,+ -- | Haskell source files to format or stdin (when the list is empty)+ optInputFiles :: ![FilePath] } -- | Mode of operation.- data Mode- = Stdout -- ^ Output formatted source code to stdout- | InPlace -- ^ Overwrite original file- | Check -- ^ Exit with non-zero status code if- -- source is not already formatted+ = -- | Output formatted source code to stdout+ Stdout+ | -- | Overwrite original file+ InPlace+ | -- | Exit with non-zero status code if+ -- source is not already formatted+ Check deriving (Eq, Show) optsParserInfo :: ParserInfo Opts-optsParserInfo = info (helper <*> ver <*> exts <*> optsParser) . mconcat $- [ fullDesc- , progDesc ""- , header ""- ]+optsParserInfo =+ info (helper <*> ver <*> exts <*> optsParser) . mconcat $+ [ fullDesc,+ progDesc "",+ header ""+ ] where ver :: Parser (a -> a)- ver = infoOption verStr . mconcat $- [ long "version"- , short 'v'- , help "Print version of the program"- ]- verStr = intercalate "\n"- [ unwords- [ "ormolu"- , showVersion version- , $gitBranch- , $gitHash+ ver =+ infoOption verStr . mconcat $+ [ long "version",+ short 'v',+ help "Print version of the program" ]- , "using ghc-lib-parser " ++ VERSION_ghc_lib_parser- ]+ verStr =+ intercalate+ "\n"+ [ unwords+ [ "ormolu",+ showVersion version,+ $gitBranch,+ $gitHash+ ],+ "using ghc-lib-parser " ++ VERSION_ghc_lib_parser+ ] exts :: Parser (a -> a)- exts = infoOption displayExts . mconcat $- [ long "manual-exts"- , help "Display extensions that need to be enabled manually"- ]+ exts =+ infoOption displayExts . mconcat $+ [ long "manual-exts",+ help "Display extensions that need to be enabled manually"+ ] displayExts = unlines $ sort (showOutputable <$> manualExts) optsParser :: Parser Opts-optsParser = Opts- <$> (option parseMode . mconcat)- [ long "mode"- , short 'm'- , metavar "MODE"- , value Stdout- , help "Mode of operation: 'stdout' (default), 'inplace', or 'check'"- ]- <*> configParser- <*> (many . strArgument . mconcat)- [ metavar "FILE"- , help "Haskell source files to format or stdin (default)"- ]+optsParser =+ Opts+ <$> (option parseMode . mconcat)+ [ long "mode",+ short 'm',+ metavar "MODE",+ value Stdout,+ help "Mode of operation: 'stdout' (default), 'inplace', or 'check'"+ ]+ <*> configParser+ <*> (many . strArgument . mconcat)+ [ metavar "FILE",+ help "Haskell source files to format or stdin (default)"+ ] configParser :: Parser Config-configParser = Config- <$> (fmap (fmap DynOption) . many . strOption . mconcat)- [ long "ghc-opt"- , short 'o'- , metavar "OPT"- , help "GHC options to enable (e.g. language extensions)"- ]- <*> (switch . mconcat)- [ long "unsafe"- , short 'u'- , help "Do formatting faster but without automatic detection of defects"- ]- <*> (switch . mconcat)- [ long "debug"- , short 'd'- , help "Output information useful for debugging"- ]- <*> (switch . mconcat)- [ long "tolerate-cpp"- , short 'p'- , help "Do not fail if CPP pragma is present"- ]- <*> (switch . mconcat)- [ long "check-idempotency"- , short 'c'- , help "Fail if formatting is not idempotent"- ]+configParser =+ Config+ <$> (fmap (fmap DynOption) . many . strOption . mconcat)+ [ long "ghc-opt",+ short 'o',+ metavar "OPT",+ help "GHC options to enable (e.g. language extensions)"+ ]+ <*> (switch . mconcat)+ [ long "unsafe",+ short 'u',+ help "Do formatting faster but without automatic detection of defects"+ ]+ <*> (switch . mconcat)+ [ long "debug",+ short 'd',+ help "Output information useful for debugging"+ ]+ <*> (switch . mconcat)+ [ long "tolerate-cpp",+ short 'p',+ help "Do not fail if CPP pragma is present"+ ]+ <*> (switch . mconcat)+ [ long "check-idempotency",+ short 'c',+ help "Fail if formatting is not idempotent"+ ] ---------------------------------------------------------------------------- -- Helpers -- | Parse 'Mode'.- parseMode :: ReadM Mode parseMode = eitherReader $ \case "stdout" -> Right Stdout
data/examples/declaration/class/dependency-super-classes-out.hs view
@@ -13,7 +13,8 @@ MonadPlus m -- Potential for failure ) => MonadParsec e s m- | m -> e s where+ | m -> e s+ where -- | 'getState' returns state getState :: m s
data/examples/declaration/class/functional-dependencies-out.hs view
@@ -14,5 +14,6 @@ b c -> a d, -- Bar a c -> b d, -- Baz a c d -> b,- a b d -> a b c d where+ a b d -> a b c d+ where baz :: a -> b
data/examples/declaration/class/multi-parameters2-out.hs view
@@ -10,7 +10,8 @@ c -- Baz bar d -- Baz baz e -- Rest- f where+ f+ where barbaz :: a -> f bazbar ::
data/examples/declaration/data/existential-multiline-out.hs view
@@ -3,3 +3,15 @@ data Foo = forall a. MkFoo a (a -> Bool) | forall a. Eq a => MkBar a++data Bar+ = forall x y.+ Bar x y x y++data Baz+ = forall x y.+ Baz+ x+ y+ x+ y
data/examples/declaration/data/existential-multiline.hs view
@@ -3,3 +3,10 @@ data Foo = forall a. MkFoo a (a -> Bool) | forall a. Eq a => MkBar a++data Bar = forall x y.+ Bar x y x y++data Baz = forall x y.+ Baz x y x+ y
+ data/examples/declaration/data/gadt/multiline-where-out.hs view
@@ -0,0 +1,7 @@+data+ Foo+ a+ b+ c+ where+ Foo :: a -> b -> c -> Foo a b c
+ data/examples/declaration/data/gadt/multiline-where.hs view
@@ -0,0 +1,6 @@+data+ Foo+ a+ b+ c where+ Foo :: a -> b -> c -> Foo a b c
+ data/examples/declaration/data/record-multi-const-out.hs view
@@ -0,0 +1,17 @@+module Main where++-- | Something.+data Foo+ = Foo+ { -- | X+ fooX :: Int,+ -- | Y+ fooY :: Int+ }+ | Bar+ { -- | X+ barX :: Int,+ -- | Y+ barY :: Int+ }+ deriving (Eq, Show)
+ data/examples/declaration/data/record-multi-const.hs view
@@ -0,0 +1,13 @@+module Main where++-- | Something.++data Foo = Foo+ { fooX :: Int -- ^ X+ , fooY :: Int -- ^ Y+ } |+ Bar+ { barX :: Int -- ^ X+ , barY :: Int -- ^ Y+ }+ deriving (Eq, Show)
data/examples/declaration/data/record-out.hs view
@@ -1,24 +1,23 @@ module Main where -- | Something.-data Foo- = Foo- { -- | X- fooX :: Int,- -- | Y- fooY :: Int,- -- | BarBaz- fooBar, fooBaz :: NonEmpty (Identity Bool),- -- | GagGog- fooGag,- fooGog ::- NonEmpty- ( Indentity- Bool- ),- -- | Huh!- fooFoo,- barBar ::- Int- }+data Foo = Foo+ { -- | X+ fooX :: Int,+ -- | Y+ fooY :: Int,+ -- | BarBaz+ fooBar, fooBaz :: NonEmpty (Identity Bool),+ -- | GagGog+ fooGag,+ fooGog ::+ NonEmpty+ ( Indentity+ Bool+ ),+ -- | Huh!+ fooFoo,+ barBar ::+ Int+ } deriving (Eq, Show)
data/examples/declaration/data/simple-broken-out.hs view
@@ -1,8 +1,7 @@ module Main where -- | Here we go.-data Foo- = Foo {unFoo :: Int}+data Foo = Foo {unFoo :: Int} deriving (Eq) -- | And once again.
data/examples/declaration/instance/data-family-instances-gadt-out.hs view
@@ -3,9 +3,11 @@ data instance Bar Int a where SameBar ::- Bar Int+ Bar Int+ Int CloseBar :: Bar Int Double OtherBar ::- Bar Int+ Bar+ Int a
data/examples/declaration/instance/data-family-instances-newtype-out.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE GADTSyntax #-} {-# LANGUAGE TypeFamilies #-} -newtype instance Foo [Double]- = DoubleListFoo- { unDoubleListFoo :: Double- }+newtype instance Foo [Double] = DoubleListFoo+ { unDoubleListFoo :: Double+ }
data/examples/declaration/type-families/closed-type-family/multi-line-out.hs view
@@ -1,7 +1,7 @@ type family Id a =- result- | result -> a where+ result | result -> a+ where Id a = a @@ -10,14 +10,15 @@ (a :: k) b c =- foo- | foo -> k b where+ foo | foo -> k b+ where G a b c = (a, b) type family F a ::- * -> * where+ * -> *+ where F Int = Double F Bool = Char
+ data/examples/declaration/type/visible-forall-out.hs view
@@ -0,0 +1,2 @@+-- source: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0081-forall-arrow.rst+data T :: forall k -> k -> Type
+ data/examples/declaration/type/visible-forall.hs view
@@ -0,0 +1,2 @@+-- source: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0081-forall-arrow.rst+data T :: forall k -> k -> Type
− data/examples/declaration/value/function/arrow/expression-applications-out.hs
@@ -1,9 +0,0 @@-{-# LANGUAGE Arrows #-}--foo x y = x -< y--bar f x =- f x -< -- Hello- x -- World--baz x y = x -<< y
− data/examples/declaration/value/function/arrow/expression-applications.hs
@@ -1,9 +0,0 @@-{-# LANGUAGE Arrows #-}--foo x y = x -< y--bar f x- = f x -- Hello- -< x -- World--baz x y = x -<< y
− data/examples/declaration/value/function/arrow/expression-forms-out.hs
@@ -1,14 +0,0 @@-{-# LANGUAGE Arrows #-}--foo f g x y = (| test (f -< x) (g -< y) |)--bar f g x y =- (|- test- ( f -<- x- )- ( g -<- y- )- |)
− data/examples/declaration/value/function/arrow/expression-forms.hs
@@ -1,11 +0,0 @@-{-# LANGUAGE Arrows #-}--foo f g x y = (| test (f -< x) (g -< y) |)--bar f g x y = (|- test- (f- -< x)- (g- -< y)- |)
+ data/examples/declaration/value/function/arrow/multiline-case-out.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE Arrows #-}++f = proc x -> do+ x <-+ case x of X -> x+ -<+ y+ a -< b
+ data/examples/declaration/value/function/arrow/multiline-case.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE Arrows #-}++f = proc x -> do+ x+ <- case x of X -> x+ -< y+ a -< b
data/examples/declaration/value/function/arrow/proc-applications-out.hs view
@@ -9,10 +9,11 @@ w ) ->- f -< -- The value- ( x, -- Foo- w, -- Bar- z -- Baz- )+ f -- The value+ -<+ ( x, -- Foo+ w, -- Bar+ z -- Baz+ ) baz x = proc a -> a -<< x
data/examples/declaration/value/function/arrow/proc-do-complex-out.hs view
@@ -19,10 +19,11 @@ ) ( b, d- ) -<- ( b + 1, -- Funnel into arrow- d * b )+ -<+ ( b + 1, -- Funnel into arrow+ d * b+ ) if x `mod` y == 0 -- Basic condition then case e of -- Only left case is relevant Left@@ -32,9 +33,10 @@ let v = u -- Actually never used ^ 2- in ( returnA -<- -- Just do the calculation- (x + y * z)+ in ( returnA+ -<+ -- Just do the calculation+ (x + y * z) ) else do let u = x -- Let bindings bind expressions, not commands@@ -42,8 +44,9 @@ i <- case u of 0 -> (g . h -< u) n ->- ( ( h . g -<- y -- First actual use of y+ ( ( h . g+ -<+ y -- First actual use of y ) ) returnA -< ()@@ -51,8 +54,9 @@ if i > 0 then ma -< () else returnA -< ()- returnA -<- ( i- + x- * y -- Just do the calculation- )+ returnA+ -<+ ( i+ + x+ * y -- Just do the calculation+ )
data/examples/declaration/value/function/arrow/proc-do-simple1-out.hs view
@@ -13,5 +13,6 @@ bazbar f = proc a -> do a <-- f -<- a+ f+ -<+ a
data/examples/declaration/value/function/arrow/proc-do-simple2-out.hs view
@@ -11,10 +11,12 @@ z <- h x- y -<- ( a,- b,- c- )- returnA -<- (x, y, z)+ y+ -<+ ( a,+ b,+ c+ )+ returnA+ -<+ (x, y, z)
data/examples/declaration/value/function/arrow/proc-forms1-out.hs view
@@ -7,13 +7,15 @@ (| test ( h f- . h g -<- y x- . y z+ . h g+ -<+ y x+ . y z ) ( h g- . h f -<- y z- . y x+ . h f+ -<+ y z+ . y x ) |)
data/examples/declaration/value/function/arrow/proc-forms2-out.hs view
@@ -4,15 +4,19 @@ proc (y, z) -> (| test (h f . (h g) -< (y x) . y z) ((h g) . h f -< y z . (y x)) |) -bar1 f g x y = proc _ -> f -< x &&& g -< y+bar1 f g x y = proc _ -> (f -< x) &&& (g -< y) bar2 f g h x = proc (y, z) ->- h f . (h g) -< (y x) . y z ||| (h g) . h f -< y z . (y x)+ (h f . (h g) -< (y x) . y z) ||| ((h g) . h f -< y z . (y x)) bar3 f g h x = proc (y, z) ->- (h f . h g) -<- (y x) . y z- ||| (h g . h f) -<- y z . (y x)+ ( (h f . h g)+ -<+ (y x) . y z+ ) |||+ ( (h g . h f)+ -<+ y z . (y x)+ )
data/examples/declaration/value/function/arrow/proc-forms2.hs view
@@ -4,16 +4,16 @@ proc (y, z) -> (| test (h f.(h g) -< (y x).y z)((h g) . h f-<y z . (y x)) |) -bar1 f g x y = proc _ -> f -< x&&&g -< y+bar1 f g x y = proc _ -> (f -< x)&&&(g -< y) bar2 f g h x = proc (y, z) ->- h f.(h g) -< (y x).y z ||| (h g) . h f-<y z . (y x)+ (h f.(h g) -< (y x).y z) ||| ((h g) . h f-<y z . (y x)) bar3 f g h x = proc (y, z) ->- (h f.h g)- -< (y x).y z+ ((h f.h g)+ -< (y x).y z) |||- (h g . h f)- -<y z . (y x)+ ((h g . h f)+ -<y z . (y x))
data/examples/declaration/value/function/arrow/proc-ifs-out.hs view
@@ -6,8 +6,10 @@ if f a then f- . g -<- a+ . g+ -<+ a else- g -<- b+ g+ -<+ b
data/examples/declaration/value/function/arrow/proc-parentheses-out.hs view
@@ -6,13 +6,14 @@ ( ( (f) ( g )- ) -<- ( ( ( ( ( ( g- a+ )+ -<+ ( ( ( ( ( ( g+ a+ ) ) ) ) ) )- ) )
data/examples/declaration/value/function/arrow/recursive-procs-out.hs view
@@ -3,17 +3,21 @@ foo f g = proc (x, y) -> do rec a <- f y -< x b <-- g x -<- y- bar -<- ( a,- b- )+ g x+ -<+ y+ bar+ -<+ ( a,+ b+ ) rec p <- f- p -<- a+ p+ -<+ a rec q <- g- q -<- b+ q+ -<+ b
data/examples/declaration/value/function/pattern/famous-cardano-pattern-out.hs view
@@ -1,8 +1,8 @@-( getNodeSettingsR :<|>- getNodeInfoR :<|>- getNextUpdateR :<|>- restartNodeR- ) :<|>- ( getUtxoR :<|>- getConfirmedProposalsR- ) = client nodeV1Api+( getNodeSettingsR+ :<|> getNodeInfoR+ :<|> getNextUpdateR+ :<|> restartNodeR+ )+ :<|> ( getUtxoR+ :<|> getConfirmedProposalsR+ ) = client nodeV1Api
data/examples/declaration/value/function/pattern/multiline-case-pattern-out.hs view
@@ -10,6 +10,6 @@ ] -> a + b g xs = case xs of- ( a :- bs+ ( a+ : bs ) -> a + b
data/examples/declaration/value/function/pattern/view-pattern-out.hs view
@@ -13,6 +13,3 @@ bar baz ) = True---- https://github.com/tweag/ormolu/issues/343-foo = (f -> 4)
data/examples/declaration/value/function/pattern/view-pattern.hs view
@@ -10,6 +10,3 @@ multiline (t -> Foo bar baz) = True---- https://github.com/tweag/ormolu/issues/343-foo = (f -> 4)
+ data/examples/import/qualified-post-out.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE ImportQualifiedPost #-}++import Data.Text qualified as T+import Data.Text qualified (a, b, c)+import Data.Text qualified hiding (a, b, c)
+ data/examples/import/qualified-post.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE ImportQualifiedPost #-}++import qualified Data.Text as T+import qualified Data.Text (a, c, b)+import Data.Text qualified hiding (c, b, a)
data/examples/import/qualified-prelude-out.hs view
@@ -1,4 +1,4 @@ module P where -import Prelude hiding ((.), id) import qualified Prelude+import Prelude hiding ((.), id)
data/examples/other/multiline-forall-out.hs view
@@ -12,8 +12,7 @@ ) (x :: *) (y :: *).- D- (f x y)+ D (f x y) data G where G ::
ormolu.cabal view
@@ -1,7 +1,7 @@ name: ormolu-version: 0.0.3.1+version: 0.0.4.0 cabal-version: 1.18-tested-with: GHC==8.6.5+tested-with: GHC==8.6.5, GHC==8.8.3, GHC==8.10.1 license: BSD3 license-file: LICENSE.md maintainer: Mark Karpov <mark.karpov@tweag.io>@@ -68,7 +68,7 @@ , containers >= 0.5 && < 0.7 , dlist >= 0.8 && < 0.9 , exceptions >= 0.6 && < 0.11- , ghc-lib-parser >= 8.8.1 && < 8.8.3+ , ghc-lib-parser >= 8.10 && < 8.11 , mtl >= 2.0 && < 3.0 , syb >= 0.7 && < 0.8 , text >= 0.2 && < 1.3@@ -116,7 +116,6 @@ -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances- -Wnoncanonical-monadfail-instances -- https://github.com/haskell/haddock/issues/1116 -Wno-missing-home-modules else@@ -150,7 +149,7 @@ main-is: Main.hs hs-source-dirs: app build-depends: base >= 4.12 && < 5.0- , ghc-lib-parser >= 8.8.1 && < 8.8.3+ , ghc-lib-parser >= 8.10 && < 8.11 , gitrev >= 1.3 && < 1.4 , optparse-applicative >= 0.14 && < 0.16 , ormolu@@ -161,7 +160,6 @@ -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances- -Wnoncanonical-monadfail-instances else- ghc-options: -O2 -Wall+ ghc-options: -O2 -Wall -rtsopts default-language: Haskell2010
src/GHC.hs view
@@ -6,16 +6,8 @@ import ApiAnnotation as X import BasicTypes as X-import HsBinds as X-import HsDecls as X-import HsDoc as X-import HsExpr as X-import HsExtension as X-import HsImpExp as X-import HsInstances as X ()-import HsLit as X-import HsPat as X-import HsSyn as X+import GHC.Hs as X+import GHC.Hs.Instances as X () import Module as X import RdrName as X import SrcLoc as X
src/GHC/DynFlags.hs view
@@ -1,5 +1,7 @@ {-# OPTIONS_GHC -Wno-missing-fields #-} +-- Modified from ghc-lib-api-ext.+ module GHC.DynFlags ( baseDynFlags, )@@ -8,31 +10,40 @@ import Config import DynFlags import Fingerprint-import Platform+import GHC.Platform+import ToolSettings --- | Taken from HLint. fakeSettings :: Settings fakeSettings = Settings- { sTargetPlatform = platform,- sPlatformConstants = platformConstants,- sProjectVersion = cProjectVersion,- sProgramName = "ghc",- sOpt_P_fingerprint = fingerprint0,- sPgm_F = ""+ { sGhcNameVersion =+ GhcNameVersion+ { ghcNameVersion_programName = "ghc",+ ghcNameVersion_projectVersion = cProjectVersion+ },+ sFileSettings = FileSettings {},+ sTargetPlatform =+ Platform+ { platformWordSize = PW8,+ platformMini =+ PlatformMini+ { platformMini_arch = ArchUnknown,+ platformMini_os = OSUnknown+ },+ platformUnregisterised = True+ },+ sPlatformMisc = PlatformMisc {},+ sPlatformConstants =+ PlatformConstants {pc_DYNAMIC_BY_DEFAULT = False, pc_WORD_SIZE = 8},+ sToolSettings =+ ToolSettings+ { toolSettings_opt_P_fingerprint = fingerprint0,+ toolSettings_pgm_F = ""+ } }- where- platform =- Platform- { platformWordSize = 8,- platformOS = OSUnknown,- platformUnregisterised = True- }- platformConstants =- PlatformConstants {pc_DYNAMIC_BY_DEFAULT = False, pc_WORD_SIZE = 8} -fakeLlvmConfig :: (LlvmTargets, LlvmPasses)-fakeLlvmConfig = ([], [])+fakeLlvmConfig :: LlvmConfig+fakeLlvmConfig = LlvmConfig [] [] baseDynFlags :: DynFlags baseDynFlags = defaultDynFlags fakeSettings fakeLlvmConfig
src/Ormolu/Config.hs view
@@ -10,21 +10,20 @@ import qualified SrcLoc as GHC -- | Ormolu configuration.-data Config- = Config- { -- | Dynamic options to pass to GHC parser- cfgDynOptions :: ![DynOption],- -- | Do formatting faster but without automatic detection of defects- cfgUnsafe :: !Bool,- -- | Output information useful for debugging- cfgDebug :: !Bool,- -- | Do not fail if CPP pragma is present (still doesn't handle CPP but- -- useful for formatting of files that enable the extension without- -- actually containing CPP macros)- cfgTolerateCpp :: !Bool,- -- | Checks if re-formatting the result is idempotent.- cfgCheckIdempotency :: !Bool- }+data Config = Config+ { -- | Dynamic options to pass to GHC parser+ cfgDynOptions :: ![DynOption],+ -- | Do formatting faster but without automatic detection of defects+ cfgUnsafe :: !Bool,+ -- | Output information useful for debugging+ cfgDebug :: !Bool,+ -- | Do not fail if CPP pragma is present (still doesn't handle CPP but+ -- useful for formatting of files that enable the extension without+ -- actually containing CPP macros)+ cfgTolerateCpp :: !Bool,+ -- | Checks if re-formatting the result is idempotent.+ cfgCheckIdempotency :: !Bool+ } deriving (Eq, Show) -- | Default 'Config'.@@ -39,10 +38,9 @@ } -- | A wrapper for dynamic options.-newtype DynOption- = DynOption- { unDynOption :: String- }+newtype DynOption = DynOption+ { unDynOption :: String+ } deriving (Eq, Ord, Show) -- | Convert 'DynOption' to @'GHC.Located' 'String'@.
src/Ormolu/Diff.hs view
@@ -8,7 +8,6 @@ ) where -import BasicTypes (SourceText) import Data.ByteString (ByteString) import Data.Generics import Data.Text (Text)@@ -71,6 +70,7 @@ `extQ` hsModuleEq `extQ` sourceTextEq `extQ` hsDocStringEq+ `extQ` importDeclQualifiedStyleEq `ext2Q` forLocated ) x@@ -88,6 +88,13 @@ hs1 {hsmodImports = sortImports (hsmodImports hs1)} sourceTextEq :: SourceText -> GenericQ Diff sourceTextEq _ _ = Same+ importDeclQualifiedStyleEq :: ImportDeclQualifiedStyle -> GenericQ Diff+ importDeclQualifiedStyleEq d0 d1' =+ case (d0, cast d1' :: Maybe ImportDeclQualifiedStyle) of+ (x, Just x') | x == x' -> Same+ (QualifiedPre, Just QualifiedPost) -> Same+ (QualifiedPost, Just QualifiedPre) -> Same+ _ -> Different [] hsDocStringEq :: HsDocString -> GenericQ Diff hsDocStringEq str0 str1' = case cast str1' :: Maybe HsDocString of
src/Ormolu/Imports.hs view
@@ -13,8 +13,8 @@ import Data.Generics (gcompare) import Data.List (sortBy) import GHC hiding (GhcPs, IE)-import HsExtension-import HsImpExp (IE (..))+import GHC.Hs.Extension+import GHC.Hs.ImpExp (IE (..)) import Ormolu.Utils (notImplemented) -- | Sort imports by module name. This also sorts explicit import lists for@@ -29,7 +29,7 @@ { ideclHiding = second (fmap sortLies) <$> ideclHiding, .. }- XImportDecl {} -> notImplemented "XImportDecl"+ XImportDecl x -> noExtCon x -- | Compare two @'LImportDecl' 'GhcPs'@ things. compareIdecl :: LImportDecl GhcPs -> LImportDecl GhcPs -> Ordering@@ -51,8 +51,8 @@ -- | Sort imports\/exports inside of 'IEThingWith'. sortThings :: IE GhcPs -> IE GhcPs sortThings = \case- IEThingWith NoExt x w xs fl ->- IEThingWith NoExt x w (sortBy (compareIewn `on` unLoc) xs) fl+ IEThingWith NoExtField x w xs fl ->+ IEThingWith NoExtField x w (sortBy (compareIewn `on` unLoc) xs) fl other -> other -- | Compare two located imports or exports.@@ -62,15 +62,15 @@ -- | Project @'IEWrappedName' 'RdrName'@ from @'IE' 'GhcPs'@. getIewn :: IE GhcPs -> IEWrappedName RdrName getIewn = \case- IEVar NoExt x -> unLoc x- IEThingAbs NoExt x -> unLoc x- IEThingAll NoExt x -> unLoc x- IEThingWith NoExt x _ _ _ -> unLoc x- IEModuleContents NoExt _ -> notImplemented "IEModuleContents"- IEGroup NoExt _ _ -> notImplemented "IEGroup"- IEDoc NoExt _ -> notImplemented "IEDoc"- IEDocNamed NoExt _ -> notImplemented "IEDocNamed"- XIE NoExt -> notImplemented "XIE"+ IEVar NoExtField x -> unLoc x+ IEThingAbs NoExtField x -> unLoc x+ IEThingAll NoExtField x -> unLoc x+ IEThingWith NoExtField x _ _ _ -> unLoc x+ IEModuleContents NoExtField _ -> notImplemented "IEModuleContents"+ IEGroup NoExtField _ _ -> notImplemented "IEGroup"+ IEDoc NoExtField _ -> notImplemented "IEDoc"+ IEDocNamed NoExtField _ -> notImplemented "IEDocNamed"+ XIE x -> noExtCon x -- | Compare two @'IEWrapppedName' 'RdrName'@ things. compareIewn :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering
src/Ormolu/Parser.hs view
@@ -9,14 +9,17 @@ ) where +import Bag (bagToList) import qualified CmdLineParser as GHC import Control.Exception import Control.Monad import Control.Monad.IO.Class-import Data.List ((\\), foldl', isPrefixOf)+import Data.List ((\\), foldl', isPrefixOf, sortOn) import qualified Data.List.NonEmpty as NE import Data.Maybe (catMaybes)+import Data.Ord (Down (Down)) import DynFlags as GHC+import ErrUtils (Severity (..), errMsgSeverity, errMsgSpan) import qualified FastString as GHC import GHC hiding (IE, UnicodeSyntax) import GHC.DynFlags (baseDynFlags)@@ -29,7 +32,6 @@ import Ormolu.Parser.Anns import Ormolu.Parser.CommentStream import Ormolu.Parser.Result-import qualified Outputable as GHC import qualified Panic as GHC import qualified Parser as GHC import qualified StringBuffer as GHC@@ -73,20 +75,36 @@ || any (("RecordDotPreprocessor" ==) . moduleNameString) (pluginModNames dynFlags)+ pStateErrors = \pstate ->+ let errs = bagToList $ GHC.getErrorMessages pstate dynFlags+ in case sortOn (Down . SeverityOrd . errMsgSeverity) errs of+ [] -> Nothing+ err : _ -> Just (errMsgSpan err, show err) -- Show instance returns a short error message r = case runParser GHC.parseModule dynFlags path input of- GHC.PFailed _ ss m ->- Left (ss, GHC.showSDoc dynFlags m)+ GHC.PFailed pstate ->+ case pStateErrors pstate of+ Just err -> Left err+ Nothing -> error "invariant violation: PFailed does not have an error" GHC.POk pstate pmod ->- let (comments, exts, shebangs) = mkCommentStream extraComments pstate- in Right- ParseResult- { prParsedSource = pmod,- prAnns = mkAnns pstate,- prCommentStream = comments,- prExtensions = exts,- prShebangs = shebangs,- prUseRecordDot = useRecordDot- }+ case pStateErrors pstate of+ -- Some parse errors (pattern/arrow syntax in expr context)+ -- do not cause a parse error, but they are replaced with "_"+ -- by the parser and the modified AST is propagated to the+ -- later stages; but we fail in those cases.+ Just err -> Left err+ Nothing ->+ let (comments, exts, shebangs) = mkCommentStream extraComments pstate+ in Right+ ParseResult+ { prParsedSource = pmod,+ prAnns = mkAnns pstate,+ prCommentStream = comments,+ prExtensions = exts,+ prShebangs = shebangs,+ prUseRecordDot = useRecordDot,+ prImportQualifiedPost =+ GHC.xopt ImportQualifiedPost dynFlags+ } return (warnings, r) -- | Extensions that are not enabled automatically and should be activated@@ -108,9 +126,11 @@ MonadComprehensions, UnboxedSums, UnicodeSyntax, -- gives special meanings to operators like (→)- TemplateHaskellQuotes -- enables TH subset of quasi-quotes, this+ TemplateHaskellQuotes, -- enables TH subset of quasi-quotes, this -- apparently interferes with QuasiQuotes in -- weird ways+ ImportQualifiedPost -- affects how Ormolu renders imports, so the+ -- decision of enabling this style is left to the user ] ----------------------------------------------------------------------------@@ -223,3 +243,25 @@ reportErr (GHC.handleSourceError reportErr act) reportErr e = return $ Left (show e)++----------------------------------------------------------------------------+-- Even more helpers++-- Wrap GHC's ErrUtils.Severity to add Ord instance+newtype SeverityOrd = SeverityOrd Severity++instance Eq SeverityOrd where+ s1 == s2 = compare s1 s2 == EQ++instance Ord SeverityOrd where+ compare (SeverityOrd s1) (SeverityOrd s2) =+ compare (f s1) (f s2)+ where+ f :: Severity -> Int+ f SevOutput = 1+ f SevFatal = 2+ f SevInteractive = 3+ f SevDump = 4+ f SevInfo = 5+ f SevWarning = 6+ f SevError = 7
src/Ormolu/Parser/Pragma.hs view
@@ -10,7 +10,7 @@ import Control.Monad import Data.Char (isSpace, toLower)-import Data.List+import qualified Data.List as L import qualified EnumSet as ES import FastString (mkFastString, unpackFS) import qualified Lexer as L@@ -35,8 +35,8 @@ String -> Maybe Pragma parsePragma input = do- inputNoPrefix <- stripPrefix "{-#" input- guard ("#-}" `isSuffixOf` input)+ inputNoPrefix <- L.stripPrefix "{-#" input+ guard ("#-}" `L.isSuffixOf` input) let contents = take (length inputNoPrefix - 3) inputNoPrefix (pragmaName, cs) = (break isSpace . dropWhile isSpace) contents case toLower <$> pragmaName of@@ -46,7 +46,7 @@ _ -> Nothing where trimSpaces :: String -> String- trimSpaces = dropWhileEnd isSpace . dropWhile isSpace+ trimSpaces = L.dropWhileEnd isSpace . dropWhile isSpace -- | Assuming the input consists of a series of tokens from a language -- pragma, return the set of enabled extensions.
src/Ormolu/Parser/Result.hs view
@@ -13,21 +13,22 @@ import Ormolu.Parser.Pragma (Pragma) -- | A collection of data that represents a parsed module in Ormolu.-data ParseResult- = ParseResult- { -- | 'ParsedSource' from GHC- prParsedSource :: ParsedSource,- -- | Ormolu-specfic representation of annotations- prAnns :: Anns,- -- | Comment stream- prCommentStream :: CommentStream,- -- | Extensions enabled in that module- prExtensions :: [Pragma],- -- | Shebangs found in the input- prShebangs :: [Located String],- -- | Whether or not record dot syntax is enabled- prUseRecordDot :: Bool- }+data ParseResult = ParseResult+ { -- | 'ParsedSource' from GHC+ prParsedSource :: ParsedSource,+ -- | Ormolu-specfic representation of annotations+ prAnns :: Anns,+ -- | Comment stream+ prCommentStream :: CommentStream,+ -- | Extensions enabled in that module+ prExtensions :: [Pragma],+ -- | Shebangs found in the input+ prShebangs :: [Located String],+ -- | Whether or not record dot syntax is enabled+ prUseRecordDot :: Bool,+ -- | Whether or not ImportQualifiedPost is enabled+ prImportQualifiedPost :: Bool+ } -- | Pretty-print a 'ParseResult'. prettyPrintParseResult :: ParseResult -> String
src/Ormolu/Printer.hs view
@@ -20,7 +20,12 @@ Text printModule ParseResult {..} = runR- (p_hsModule prShebangs prExtensions prParsedSource)+ ( p_hsModule+ prShebangs+ prExtensions+ prImportQualifiedPost+ prParsedSource+ ) (mkSpanStream prParsedSource) prCommentStream prAnns
src/Ormolu/Printer/Combinators.hs view
@@ -23,7 +23,6 @@ inci, located, located',- locatedPat, switchLayout, Layout (..), vlayout,@@ -64,7 +63,6 @@ import Data.Data (Data) import Data.List (intersperse) import Data.Text (Text)-import GHC (Pat (XPat), XXPat) import Ormolu.Printer.Comments import Ormolu.Printer.Internal import Ormolu.Utils (isModule)@@ -110,28 +108,6 @@ Located a -> R () located' = flip located---- | A version of 'located' that works on 'Pat'.------ Starting from GHC 8.8, @'LPat' == 'Pat'@. Located 'Pat's are always--- constructed with the 'XPat' constructor, containing a @'Located' 'Pat'@.------ Most of the time, we can just use 'p_pat' directly, because it handles--- located 'Pat's. However, sometimes we want to use the location to render--- something other than the given 'Pat'.------ If given 'Pat' does not contain a location, we error out.------ This should become unnecessary if--- <https://gitlab.haskell.org/ghc/ghc/issues/17330> is ever fixed.-locatedPat ::- (Data (Pat pass), XXPat pass ~ Located (Pat pass)) =>- Pat pass ->- (Pat pass -> R ()) ->- R ()-locatedPat p f = case p of- XPat pat -> located pat f- _ -> error "locatedPat: Pat does not contain a location" -- | Set layout according to combination of given 'SrcSpan's for a given. -- Use this only when you need to set layout based on e.g. combined span of
src/Ormolu/Printer/Internal.hs view
@@ -73,45 +73,43 @@ -- | Reader context of 'R'. This should be used when we control rendering by -- enclosing certain expressions with wrappers.-data RC- = RC- { -- | Indentation level, as the column index we need to start from after- -- a newline if we break lines- rcIndent :: !Int,- -- | Current layout- 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- }+data RC = RC+ { -- | Indentation level, as the column index we need to start from after+ -- a newline if we break lines+ rcIndent :: !Int,+ -- | Current layout+ 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+ } -- | State context of 'R'.-data SC- = SC- { -- | Index of the next column to render- scColumn :: !Int,- -- | Rendered source code so far- scBuilder :: Builder,- -- | Span stream- scSpanStream :: SpanStream,- -- | Comment stream- scCommentStream :: CommentStream,- -- | Pending comment lines (in reverse order) to be inserted before next- -- newline, 'Int' is the indentation level- scPendingComments :: ![(CommentPosition, Int, Text)],- -- | Whether the current line is “dirty”, that is, already contains- -- atoms that can have comments attached to them- scDirtyLine :: !Bool,- -- | Whether to output a space before the next output- scRequestedDelimiter :: !RequestedDelimiter,- -- | Span of last output comment- scLastCommentSpan :: !(Maybe (Maybe HaddockStyle, RealSrcSpan))- }+data SC = SC+ { -- | Index of the next column to render+ scColumn :: !Int,+ -- | Rendered source code so far+ scBuilder :: Builder,+ -- | Span stream+ scSpanStream :: SpanStream,+ -- | Comment stream+ scCommentStream :: CommentStream,+ -- | Pending comment lines (in reverse order) to be inserted before next+ -- newline, 'Int' is the indentation level+ scPendingComments :: ![(CommentPosition, Int, Text)],+ -- | Whether the current line is “dirty”, that is, already contains+ -- atoms that can have comments attached to them+ scDirtyLine :: !Bool,+ -- | Whether to output a space before the next output+ scRequestedDelimiter :: !RequestedDelimiter,+ -- | Span of last output comment+ scLastCommentSpan :: !(Maybe (Maybe HaddockStyle, RealSrcSpan))+ } -- | Make sure next output is delimited by one of the following. data RequestedDelimiter
src/Ormolu/Printer/Meat/Common.hs view
@@ -24,7 +24,6 @@ import OccName (OccName (..)) import Ormolu.Printer.Combinators import Ormolu.Utils-import RdrName (RdrName (..)) -- | Data and type family style. data FamilyStyle
src/Ormolu/Printer/Meat/Declaration.hs view
@@ -34,7 +34,6 @@ import Ormolu.Printer.Meat.Declaration.Warning import Ormolu.Printer.Meat.Type import Ormolu.Utils-import RdrName (rdrNameOcc) data UserGrouping = -- | Always put newlines where we think they should be@@ -110,29 +109,30 @@ p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R () p_hsDecl style = \case- TyClD NoExt x -> p_tyClDecl style x- ValD NoExt x -> p_valDecl x- SigD NoExt x -> p_sigDecl x- InstD NoExt x -> p_instDecl style x- DerivD NoExt x -> p_derivDecl x- DefD NoExt x -> p_defaultDecl x- ForD NoExt x -> p_foreignDecl x- WarningD NoExt x -> p_warnDecls x- AnnD NoExt x -> p_annDecl x- RuleD NoExt x -> p_ruleDecls x- SpliceD NoExt x -> p_spliceDecl x- DocD NoExt docDecl ->+ 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_derivDecl 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 -> 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 NoExt x -> p_roleAnnot x- XHsDecl _ -> notImplemented "XHsDecl"+ RoleAnnotD NoExtField x -> p_roleAnnot x+ KindSigD NoExtField s -> p_standaloneKindSig s+ XHsDecl x -> noExtCon x p_tyClDecl :: FamilyStyle -> TyClDecl GhcPs -> R () p_tyClDecl style = \case- FamDecl NoExt x -> p_famDecl style x+ FamDecl NoExtField x -> p_famDecl style x SynDecl {..} -> p_synDecl tcdLName tcdFixity tcdTyVars tcdRhs DataDecl {..} -> p_dataDecl@@ -153,19 +153,19 @@ tcdATs tcdATDefs tcdDocs- XTyClDecl {} -> notImplemented "XTyClDecl"+ XTyClDecl x -> noExtCon x p_instDecl :: FamilyStyle -> InstDecl GhcPs -> R () p_instDecl style = \case- ClsInstD NoExt x -> p_clsInstDecl x- TyFamInstD NoExt x -> p_tyFamInstDecl style x- DataFamInstD NoExt x -> p_dataFamInstDecl style x- XInstDecl _ -> notImplemented "XInstDecl"+ ClsInstD NoExtField x -> p_clsInstDecl x+ TyFamInstD NoExtField x -> p_tyFamInstDecl style x+ DataFamInstD NoExtField x -> p_dataFamInstDecl style x+ XInstDecl x -> noExtCon x p_derivDecl :: DerivDecl GhcPs -> R () p_derivDecl = \case- d@DerivDecl {..} -> p_standaloneDerivDecl d- XDerivDecl _ -> notImplemented "XDerivDecl standalone deriving"+ d@DerivDecl {} -> p_standaloneDerivDecl d+ XDerivDecl x -> noExtCon x -- | Determine if these declarations should be grouped together. groupedDecls ::@@ -186,6 +186,9 @@ groupedDecls x (TypeSignature ns) | Just ns' <- isPragma x = ns `intersects` ns' groupedDecls (TypeSignature ns) x | Just ns' <- isPragma x = ns `intersects` ns' groupedDecls (PatternSignature ns) (Pattern n) = n `elem` ns+groupedDecls (KindSignature n) (DataDeclaration n') = n == n'+groupedDecls (KindSignature n) (ClassDeclaration n') = n == n'+groupedDecls (KindSignature n) (FamilyDeclaration n') = n == n' -- This looks only at Haddocks, normal comments are handled elsewhere groupedDecls DocNext _ = True groupedDecls _ DocPrev = True@@ -223,15 +226,21 @@ AnnTypePragma, AnnValuePragma, Pattern,- DataDeclaration ::+ DataDeclaration,+ ClassDeclaration,+ KindSignature,+ FamilyDeclaration :: RdrName -> HsDecl GhcPs-pattern InlinePragma n <- SigD NoExt (InlineSig NoExt (L _ n) _)-pattern SpecializePragma n <- SigD NoExt (SpecSig NoExt (L _ n) _ _)-pattern SCCPragma n <- SigD NoExt (SCCFunSig NoExt _ (L _ n) _)-pattern AnnTypePragma n <- AnnD NoExt (HsAnnotation NoExt _ (TypeAnnProvenance (L _ n)) _)-pattern AnnValuePragma n <- AnnD NoExt (HsAnnotation NoExt _ (ValueAnnProvenance (L _ n)) _)-pattern Pattern n <- ValD NoExt (PatSynBind NoExt (PSB _ (L _ n) _ _ _))-pattern DataDeclaration n <- TyClD NoExt (DataDecl NoExt (L _ n) _ _ _)+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 NoExtField _ (L _ n) _ _ _ _ _ _ _ _)+pattern KindSignature n <- KindSigD NoExtField (StandaloneKindSig NoExtField (L _ n) _)+pattern FamilyDeclaration n <- TyClD NoExtField (FamDecl NoExtField (FamilyDecl NoExtField _ (L _ n) _ _ _ _)) -- Declarations which can refer to multiple names @@ -249,51 +258,51 @@ pattern WarningPragma n <- (warnSigRdrNames -> Just n) pattern DocNext, DocPrev :: HsDecl GhcPs-pattern DocNext <- (DocD NoExt (DocCommentNext _))-pattern DocPrev <- (DocD NoExt (DocCommentPrev _))+pattern DocNext <- (DocD NoExtField (DocCommentNext _))+pattern DocPrev <- (DocD NoExtField (DocCommentPrev _)) sigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]-sigRdrNames (SigD NoExt (TypeSig NoExt ns _)) = Just $ map unLoc ns-sigRdrNames (SigD NoExt (ClassOpSig NoExt _ ns _)) = Just $ map unLoc ns-sigRdrNames (SigD NoExt (PatSynSig NoExt ns _)) = Just $ map unLoc ns+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 _ = Nothing defSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]-defSigRdrNames (SigD NoExt (ClassOpSig NoExt True ns _)) = Just $ map unLoc ns+defSigRdrNames (SigD NoExtField (ClassOpSig NoExtField True ns _)) = Just $ map unLoc ns defSigRdrNames _ = Nothing funRdrNames :: HsDecl GhcPs -> Maybe [RdrName]-funRdrNames (ValD NoExt (FunBind NoExt (L _ n) _ _ _)) = Just [n]-funRdrNames (ValD NoExt (PatBind NoExt n _ _)) = Just $ patBindNames n+funRdrNames (ValD NoExtField (FunBind NoExtField (L _ n) _ _ _)) = Just [n]+funRdrNames (ValD NoExtField (PatBind NoExtField (L _ n) _ _)) = Just $ patBindNames n funRdrNames _ = Nothing patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]-patSigRdrNames (SigD NoExt (PatSynSig NoExt ns _)) = Just $ map unLoc ns+patSigRdrNames (SigD NoExtField (PatSynSig NoExtField ns _)) = Just $ map unLoc ns patSigRdrNames _ = Nothing warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]-warnSigRdrNames (WarningD NoExt (Warnings NoExt _ ws)) = Just $ flip concatMap ws $ \case- L _ (Warning NoExt ns _) -> map unLoc ns- L _ (XWarnDecl NoExt) -> []+warnSigRdrNames (WarningD NoExtField (Warnings NoExtField _ ws)) = Just $ flip concatMap ws $ \case+ L _ (Warning NoExtField ns _) -> map unLoc ns+ L _ (XWarnDecl x) -> noExtCon x warnSigRdrNames _ = Nothing patBindNames :: Pat GhcPs -> [RdrName]-patBindNames (TuplePat NoExt ps _) = concatMap (patBindNames . unLoc) ps-patBindNames (VarPat NoExt (L _ n)) = [n]-patBindNames (WildPat NoExt) = []-patBindNames (LazyPat NoExt p) = patBindNames p-patBindNames (BangPat NoExt p) = patBindNames p-patBindNames (ParPat NoExt p) = patBindNames p-patBindNames (ListPat NoExt ps) = concatMap (patBindNames . unLoc) ps-patBindNames (AsPat NoExt (L _ n) p) = n : patBindNames p-patBindNames (SumPat NoExt p _ _) = patBindNames p-patBindNames (ViewPat NoExt _ p) = patBindNames p-patBindNames (SplicePat NoExt _) = []-patBindNames (LitPat NoExt _) = []-patBindNames (SigPat _ p _) = patBindNames p-patBindNames (NPat NoExt _ _ _) = []-patBindNames (NPlusKPat NoExt (L _ n) _ _ _ _) = [n]+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 (SigPat _ (L _ p) _) = patBindNames p+patBindNames (NPat NoExtField _ _ _) = []+patBindNames (NPlusKPat NoExtField (L _ n) _ _ _ _) = [n] patBindNames (ConPatIn _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d) patBindNames ConPatOut {} = notImplemented "ConPatOut" -- created by renamer-patBindNames (CoPat NoExt _ p _) = patBindNames p-patBindNames (XPat p) = patBindNames (unLoc p)+patBindNames (CoPat NoExtField _ p _) = patBindNames p+patBindNames (XPat x) = noExtCon x
src/Ormolu/Printer/Meat/Declaration/Annotation.hs view
@@ -10,15 +10,14 @@ import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Declaration.Value-import Ormolu.Utils p_annDecl :: AnnDecl GhcPs -> R () p_annDecl = \case- HsAnnotation NoExt _ annProv expr -> pragma "ANN" . inci $ do+ HsAnnotation NoExtField _ annProv expr -> pragma "ANN" . inci $ do p_annProv annProv breakpoint located expr p_hsExpr- XAnnDecl {} -> notImplemented "XAnnDecl"+ XAnnDecl x -> noExtCon x p_annProv :: AnnProvenance (IdP GhcPs) -> R () p_annProv = \case
src/Ormolu/Printer/Meat/Declaration/Class.hs view
@@ -18,8 +18,6 @@ import Ormolu.Printer.Meat.Common import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration import Ormolu.Printer.Meat.Type-import Ormolu.Utils-import RdrName (RdrName (..)) p_classDecl :: LHsContext GhcPs ->@@ -30,7 +28,7 @@ [LSig GhcPs] -> LHsBinds GhcPs -> [LFamilyDecl GhcPs] ->- [LTyFamDefltEqn GhcPs] ->+ [LTyFamDefltDecl GhcPs] -> [LDocDecl] -> R () p_classDecl ctx name HsQTvs {..} fixity fdeps csigs cdefs cats catdefs cdocs = do@@ -38,6 +36,20 @@ signatureSpans = getLoc name : variableSpans dependencySpans = getLoc <$> fdeps combinedSpans = getLoc 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+ tyFamDefs =+ ( getLoc &&& fmap (InstD NoExtField . TyFamInstD NoExtField)+ )+ <$> catdefs+ allDecls =+ snd <$> sortOn fst (sigs <> vals <> tyFams <> tyFamDefs <> docs) txt "class" switchLayout combinedSpans $ do breakpoint@@ -50,26 +62,13 @@ (p_rdrName name) (located' p_hsTyVarBndr <$> hsq_explicit) inci (p_classFundeps fdeps)- -- 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 NoExt)) <$> csigs- vals = (getLoc &&& fmap (ValD NoExt)) <$> toList cdefs- tyFams = (getLoc &&& fmap (TyClD NoExt . FamDecl NoExt)) <$> cats- docs = (getLoc &&& fmap (DocD NoExt)) <$> cdocs- tyFamDefs =- ( getLoc &&& fmap (InstD NoExt . TyFamInstD NoExt . defltEqnToInstDecl)- )- <$> catdefs- allDecls =- snd <$> sortOn fst (sigs <> vals <> tyFams <> tyFamDefs <> docs)+ unless (null allDecls) $ do+ breakpoint+ txt "where" unless (null allDecls) $ do- space- txt "where" breakpoint -- Ensure whitespace is added after where clause. inci (p_hsDeclsRespectGrouping Associated allDecls)-p_classDecl _ _ XLHsQTyVars {} _ _ _ _ _ _ _ = notImplemented "XLHsQTyVars"+p_classDecl _ _ (XLHsQTyVars c) _ _ _ _ _ _ _ = noExtCon c p_classContext :: LHsContext GhcPs -> R () p_classContext ctx = unless (null (unLoc ctx)) $ do@@ -95,13 +94,6 @@ ---------------------------------------------------------------------------- -- Helpers--defltEqnToInstDecl :: TyFamDefltEqn GhcPs -> TyFamInstDecl GhcPs-defltEqnToInstDecl FamEqn {..} = TyFamInstDecl {..}- where- eqn = FamEqn {feqn_pats = map HsValArg (tyVarsToTypes feqn_pats), ..}- tfid_eqn = HsIB {hsib_ext = NoExt, hsib_body = eqn}-defltEqnToInstDecl XFamEqn {} = notImplemented "XFamEqn" isInfix :: LexicalFixity -> Bool isInfix = \case
src/Ormolu/Printer/Meat/Declaration/Data.hs view
@@ -15,8 +15,6 @@ import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Type import Ormolu.Utils-import RdrName (RdrName (..))-import SrcLoc (Located) p_dataDecl :: -- | Whether to format as data family@@ -37,7 +35,8 @@ txt $ case style of Associated -> mempty Free -> " instance"- switchLayout (getLoc name : fmap getLoc tpats) $ do+ let constructorSpans = getLoc name : fmap getLoc tpats+ switchLayout constructorSpans $ do breakpoint inci $ p_infixDefHelper@@ -55,29 +54,40 @@ let gadt = isJust dd_kindSig || any (isGadt . unLoc) dd_cons unless (null dd_cons) $ if gadt- then do- space- txt "where"+ then inci $ do+ switchLayout constructorSpans $ do+ breakpoint+ txt "where" breakpoint- inci $ sepSemi (located' p_conDecl) dd_cons+ sepSemi (located' (p_conDecl False)) dd_cons else switchLayout (getLoc name : (getLoc <$> dd_cons)) $ inci $ do- breakpoint+ let singleConstRec = isSingleConstRec dd_cons+ if singleConstRec+ then space+ else breakpoint txt "=" space let s = vlayout (space >> txt "|" >> space) (newline >> txt "|" >> space)- sep s (sitcc . located' p_conDecl) dd_cons+ sitcc' =+ if singleConstRec+ 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-p_dataDecl _ _ _ _ (XHsDataDefn NoExt) = notImplemented "XHsDataDefn"+p_dataDecl _ _ _ _ (XHsDataDefn x) = noExtCon x -p_conDecl :: ConDecl GhcPs -> R ()-p_conDecl = \case+p_conDecl ::+ Bool ->+ ConDecl GhcPs ->+ R ()+p_conDecl singleConstRec = \case ConDeclGADT {..} -> do mapM_ (p_hsDocString Pipe True) con_doc let conDeclSpn =@@ -104,7 +114,7 @@ else breakpoint interArgBreak when (unLoc con_forall) $ do- p_forallBndrs p_hsTyVarBndr (hsq_explicit con_qvars)+ p_forallBndrs ForallInvis p_hsTyVarBndr (hsq_explicit con_qvars) interArgBreak forM_ con_mb_cxt p_lhsContext case con_args of@@ -124,18 +134,19 @@ p_hsType (unLoc con_res_ty) ConDeclH98 {..} -> do mapM_ (p_hsDocString Pipe True) con_doc- let conDeclSpn =- [getLoc con_name]- <> [getLoc con_forall]+ let conDeclWithContextSpn =+ [getLoc con_forall] <> fmap getLoc con_ex_tvs <> maybeToList (fmap getLoc con_mb_cxt)- <> conArgsSpans con_args- switchLayout conDeclSpn $ do+ <> conDeclSpn+ conDeclSpn =+ getLoc con_name : conArgsSpans con_args+ switchLayout conDeclWithContextSpn $ do when (unLoc con_forall) $ do- p_forallBndrs p_hsTyVarBndr con_ex_tvs+ p_forallBndrs ForallInvis p_hsTyVarBndr con_ex_tvs breakpoint forM_ con_mb_cxt p_lhsContext- case con_args of+ switchLayout conDeclSpn $ case con_args of PrefixCon xs -> do p_rdrName con_name unless (null xs) breakpoint@@ -143,7 +154,11 @@ RecCon l -> do p_rdrName con_name breakpoint- inci $ located l p_conDeclFields+ let inci' =+ if singleConstRec+ then id+ else inci+ inci' (located l p_conDeclFields) InfixCon x y -> do located x p_hsType breakpoint@@ -151,7 +166,7 @@ p_rdrName con_name space located y p_hsType- XConDecl NoExt -> notImplemented "XConDecl"+ XConDecl x -> noExtCon x conArgsSpans :: HsConDeclDetails GhcPs -> [SrcSpan] conArgsSpans = \case@@ -165,7 +180,7 @@ conTyVarsSpans :: LHsQTyVars GhcPs -> [SrcSpan] conTyVarsSpans = \case HsQTvs {..} -> getLoc <$> hsq_explicit- XLHsQTyVars NoExt -> []+ XLHsQTyVars x -> noExtCon x p_lhsContext :: LHsContext GhcPs ->@@ -223,9 +238,9 @@ txt "via" space located hsib_body p_hsType- ViaStrategy (XHsImplicitBndrs NoExt) ->- notImplemented "XHsImplicitBndrs"-p_hsDerivingClause (XHsDerivingClause NoExt) = notImplemented "XHsDerivingClause"+ ViaStrategy (XHsImplicitBndrs x) ->+ noExtCon x+p_hsDerivingClause (XHsDerivingClause x) = noExtCon x ---------------------------------------------------------------------------- -- Helpers@@ -234,3 +249,10 @@ isInfix = \case Infix -> True Prefix -> False++isSingleConstRec :: [LConDecl GhcPs] -> Bool+isSingleConstRec [(L _ ConDeclH98 {..})] =+ case con_args of+ RecCon _ -> True+ _ -> False+isSingleConstRec _ = False
src/Ormolu/Printer/Meat/Declaration/Default.hs view
@@ -9,13 +9,12 @@ import GHC import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Type-import Ormolu.Utils p_defaultDecl :: DefaultDecl GhcPs -> R () p_defaultDecl = \case- DefaultDecl NoExt ts -> do+ DefaultDecl NoExtField ts -> do txt "default" breakpoint inci . parens N . sitcc $ sep (comma >> breakpoint) (sitcc . located' p_hsType) ts- XDefaultDecl {} -> notImplemented "XDefaultDecl"+ XDefaultDecl x -> noExtCon x
src/Ormolu/Printer/Meat/Declaration/Foreign.hs view
@@ -15,7 +15,6 @@ import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Declaration.Signature-import Ormolu.Utils p_foreignDecl :: ForeignDecl GhcPs -> R () p_foreignDecl = \case@@ -25,7 +24,7 @@ fd@ForeignExport {fd_fe} -> do p_foreignExport fd_fe p_foreignTypeSig fd- XForeignDecl {} -> notImplemented "XForeignDecl"+ XForeignDecl x -> noExtCon x -- | Printer for the last part of an import\/export, which is function name -- and type signature.@@ -39,7 +38,7 @@ ] $ do p_rdrName (fd_name fd)- p_typeAscription (HsWC NoExt (fd_sig_ty fd))+ p_typeAscription (HsWC NoExtField (fd_sig_ty fd)) -- | Printer for 'ForeignImport'. --
src/Ormolu/Printer/Meat/Declaration/Instance.hs view
@@ -56,8 +56,8 @@ inci (located hsib_body p_hsType) breakpoint instTypes True- ViaStrategy (XHsImplicitBndrs NoExt) ->- notImplemented "XHsImplicitBndrs"+ ViaStrategy (XHsImplicitBndrs x) ->+ noExtCon x p_standaloneDerivDecl (XDerivDecl _) = notImplemented "XDerivDecl" p_clsInstDecl :: ClsInstDecl GhcPs -> R ()@@ -70,14 +70,14 @@ -- 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 NoExt)) <$> cid_sigs- vals = (getLoc &&& fmap (ValD NoExt)) <$> toList cid_binds+ let sigs = (getLoc &&& fmap (SigD NoExtField)) <$> cid_sigs+ vals = (getLoc &&& fmap (ValD NoExtField)) <$> toList cid_binds tyFamInsts =- ( getLoc &&& fmap (InstD NoExt . TyFamInstD NoExt)+ ( getLoc &&& fmap (InstD NoExtField . TyFamInstD NoExtField) ) <$> cid_tyfam_insts dataFamInsts =- ( getLoc &&& fmap (InstD NoExt . DataFamInstD NoExt)+ ( getLoc &&& fmap (InstD NoExtField . DataFamInstD NoExtField) ) <$> cid_datafam_insts allDecls =@@ -96,8 +96,8 @@ -- Ensure whitespace is added after where clause. breakpoint dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls- XHsImplicitBndrs NoExt -> notImplemented "XHsImplicitBndrs"- XClsInstDecl NoExt -> notImplemented "XClsInstDecl"+ XHsImplicitBndrs x -> noExtCon x+ XClsInstDecl x -> noExtCon x p_tyFamInstDecl :: FamilyStyle -> TyFamInstDecl GhcPs -> R () p_tyFamInstDecl style = \case
src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs view
@@ -12,14 +12,11 @@ import GHC import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common-import Ormolu.Utils-import RdrName (RdrName (..))-import SrcLoc (Located) p_roleAnnot :: RoleAnnotDecl GhcPs -> R () p_roleAnnot = \case- RoleAnnotDecl NoExt l_name anns -> p_roleAnnot' l_name anns- XRoleAnnotDecl _ -> notImplemented "XRoleAnnotDecl"+ RoleAnnotDecl NoExtField l_name anns -> p_roleAnnot' l_name anns+ XRoleAnnotDecl x -> noExtCon x p_roleAnnot' :: Located RdrName -> [Located (Maybe Role)] -> R () p_roleAnnot' l_name anns = do
src/Ormolu/Printer/Meat/Declaration/Rule.hs view
@@ -14,18 +14,17 @@ import Ormolu.Printer.Meat.Declaration.Signature import Ormolu.Printer.Meat.Declaration.Value import Ormolu.Printer.Meat.Type-import Ormolu.Utils p_ruleDecls :: RuleDecls GhcPs -> R () p_ruleDecls = \case- HsRules NoExt _ xs ->+ HsRules NoExtField _ xs -> pragma "RULES" . sitcc $ sep breakpoint (sitcc . located' p_ruleDecl) xs- XRuleDecls NoExt -> notImplemented "XRuleDecls"+ XRuleDecls x -> noExtCon x p_ruleDecl :: RuleDecl GhcPs -> R () p_ruleDecl = \case- HsRule NoExt ruleName activation tyvars ruleBndrs lhs rhs -> do+ HsRule NoExtField ruleName activation tyvars ruleBndrs lhs rhs -> do located ruleName p_ruleName space p_activation activation@@ -33,13 +32,13 @@ case tyvars of Nothing -> return () Just xs -> do- p_forallBndrs p_hsTyVarBndr xs+ p_forallBndrs ForallInvis p_hsTyVarBndr xs space -- It appears that there is no way to tell if there was an empty forall -- 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 p_ruleBndr ruleBndrs+ p_forallBndrs ForallInvis p_ruleBndr ruleBndrs breakpoint inci $ do located lhs p_hsExpr@@ -48,15 +47,15 @@ inci $ do breakpoint located rhs p_hsExpr- XRuleDecl NoExt -> notImplemented "XRuleDecl"+ XRuleDecl x -> noExtCon x p_ruleName :: (SourceText, RuleName) -> R ()-p_ruleName (_, name) = atom $ HsString NoSourceText name+p_ruleName (_, name) = atom $ (HsString NoSourceText name :: HsLit GhcPs) p_ruleBndr :: RuleBndr GhcPs -> R () p_ruleBndr = \case- RuleBndr NoExt x -> p_rdrName x- RuleBndrSig NoExt x hswc -> parens N $ do+ RuleBndr NoExtField x -> p_rdrName x+ RuleBndrSig NoExtField x hswc -> parens N $ do p_rdrName x p_typeAscription hswc- XRuleBndr NoExt -> notImplemented "XRuleBndr"+ XRuleBndr x -> noExtCon x
src/Ormolu/Printer/Meat/Declaration/Signature.hs view
@@ -7,6 +7,7 @@ ( p_sigDecl, p_typeAscription, p_activation,+ p_standaloneKindSig, ) where @@ -22,16 +23,16 @@ p_sigDecl :: Sig GhcPs -> R () p_sigDecl = \case- TypeSig NoExt names hswc -> p_typeSig True names hswc- PatSynSig NoExt names hsib -> p_patSynSig names hsib- ClassOpSig NoExt def names hsib -> p_classOpSig def names hsib- FixSig NoExt sig -> p_fixSig sig- InlineSig NoExt name inlinePragma -> p_inlineSig name inlinePragma- SpecSig NoExt name ts inlinePragma -> p_specSig name ts inlinePragma- SpecInstSig NoExt _ hsib -> p_specInstSig hsib- MinimalSig NoExt _ booleanFormula -> p_minimalSig booleanFormula- CompleteMatchSig NoExt _sourceText cs ty -> p_completeSig cs ty- SCCFunSig NoExt _ name literal -> p_sccSig name literal+ 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 _ -> notImplemented "certain types of signature declarations" p_typeSig ::@@ -65,7 +66,7 @@ then newline else breakpoint located t p_hsType-p_typeAscription (XHsWildCardBndrs NoExt) = notImplemented "XHsWildCardBndrs"+p_typeAscription (XHsWildCardBndrs x) = noExtCon x p_patSynSig :: [Located RdrName] ->@@ -73,7 +74,7 @@ R () p_patSynSig names hsib = do txt "pattern"- let body = p_typeSig False names HsWC {hswc_ext = NoExt, hswc_body = hsib}+ let body = p_typeSig False names HsWC {hswc_ext = NoExtField, hswc_body = hsib} if length names > 1 then breakpoint >> inci body else space >> body@@ -88,13 +89,13 @@ R () p_classOpSig def names hsib = do when def (txt "default" >> space)- p_typeSig True names HsWC {hswc_ext = NoExt, hswc_body = hsib}+ p_typeSig True names HsWC {hswc_ext = NoExtField, hswc_body = hsib} p_fixSig :: FixitySig GhcPs -> R () p_fixSig = \case- FixitySig NoExt names (Fixity _ n dir) -> do+ FixitySig NoExtField names (Fixity _ n dir) -> do txt $ case dir of InfixL -> "infixl" InfixR -> "infixr"@@ -103,7 +104,7 @@ atom n space sitcc $ sep (comma >> breakpoint) p_rdrName names- XFixitySig NoExt -> notImplemented "XFixitySig"+ XFixitySig x -> noExtCon x p_inlineSig :: -- | Name@@ -218,3 +219,16 @@ forM_ literal $ \x -> do breakpoint atom x++p_standaloneKindSig :: StandaloneKindSig GhcPs -> R ()+p_standaloneKindSig (StandaloneKindSig NoExtField name bndrs) = do+ txt "type"+ space+ p_rdrName name+ space+ txt "::"+ breakpoint+ inci $ case bndrs of+ HsIB NoExtField sig -> located sig p_hsType+ XHsImplicitBndrs x -> noExtCon x+p_standaloneKindSig (XStandaloneKindSig c) = noExtCon c
src/Ormolu/Printer/Meat/Declaration/Splice.hs view
@@ -8,9 +8,8 @@ import GHC import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Declaration.Value (p_hsSplice)-import Ormolu.Utils p_spliceDecl :: SpliceDecl GhcPs -> R () p_spliceDecl = \case- SpliceDecl NoExt splice _explicit -> located splice p_hsSplice- XSpliceDecl {} -> notImplemented "XSpliceDecl"+ SpliceDecl NoExtField splice _explicit -> located splice p_hsSplice+ XSpliceDecl x -> noExtCon x
src/Ormolu/Printer/Meat/Declaration/Type.hs view
@@ -11,9 +11,6 @@ import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Type-import Ormolu.Utils (notImplemented)-import RdrName (RdrName (..))-import SrcLoc (Located) p_synDecl :: -- | Type constructor@@ -38,4 +35,4 @@ txt "=" breakpoint inci (located t p_hsType)-p_synDecl _ _ XLHsQTyVars {} _ = notImplemented "XLHsQTyVars"+p_synDecl _ _ (XLHsQTyVars x) _ = noExtCon x
src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs view
@@ -9,15 +9,13 @@ ) where -import BasicTypes (LexicalFixity (..)) import Control.Monad-import Data.Maybe (isJust, isNothing)+import Data.Maybe (isNothing) import GHC import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Type import Ormolu.Utils-import SrcLoc (GenLocated (..), Located) p_famDecl :: FamilyStyle -> FamilyDecl GhcPs -> R () p_famDecl style FamilyDecl {fdTyVars = HsQTvs {..}, ..} = do@@ -36,17 +34,18 @@ inci (p_rdrName fdLName) (located' p_hsTyVarBndr <$> hsq_explicit)- let rsig = p_familyResultSigL fdResultSig- unless (isNothing rsig && isNothing fdInjectivityAnn) space+ let resultSig = p_familyResultSigL fdResultSig+ unless (isNothing resultSig && isNothing fdInjectivityAnn) space inci $ do- sequence_ rsig- when (isJust rsig && isJust fdInjectivityAnn) breakpoint+ sequence_ resultSig+ space forM_ fdInjectivityAnn (located' p_injectivityAnn) case mmeqs of Nothing -> return () Just meqs -> do- space- txt "where"+ inci $ do+ breakpoint+ txt "where" case meqs of Nothing -> do space@@ -56,7 +55,7 @@ sep newline (located' (inci . p_tyFamInstEqn)) eqs p_famDecl _ FamilyDecl {fdTyVars = XLHsQTyVars {}} = notImplemented "XLHsQTyVars"-p_famDecl _ (XFamilyDecl NoExt) = notImplemented "XFamilyDecl"+p_famDecl _ (XFamilyDecl x) = noExtCon x p_familyResultSigL :: Located (FamilyResultSig GhcPs) ->@@ -64,17 +63,17 @@ p_familyResultSigL l = case l of L _ a -> case a of- NoSig NoExt -> Nothing- KindSig NoExt k -> Just $ do+ NoSig NoExtField -> Nothing+ KindSig NoExtField k -> Just $ do txt "::" breakpoint located k p_hsType- TyVarSig NoExt bndr -> Just $ do+ TyVarSig NoExtField bndr -> Just $ do txt "=" breakpoint located bndr p_hsTyVarBndr- XFamilyResultSig NoExt ->- notImplemented "XFamilyResultSig"+ XFamilyResultSig x ->+ noExtCon x p_injectivityAnn :: InjectivityAnn GhcPs -> R () p_injectivityAnn (InjectivityAnn a bs) = do@@ -91,7 +90,7 @@ case feqn_bndrs of Nothing -> return () Just bndrs -> do- p_forallBndrs p_hsTyVarBndr bndrs+ p_forallBndrs ForallInvis p_hsTyVarBndr bndrs breakpoint (if null feqn_bndrs then id else inci) $ do let famLhsSpn = getLoc feqn_tycon : fmap (getLoc . typeArgToType) feqn_pats@@ -105,8 +104,8 @@ txt "=" breakpoint inci (located feqn_rhs p_hsType)-p_tyFamInstEqn HsIB {hsib_body = XFamEqn {}} = notImplemented "HsIB XFamEqn"-p_tyFamInstEqn (XHsImplicitBndrs NoExt) = notImplemented "XHsImplicitBndrs"+p_tyFamInstEqn HsIB {hsib_body = XFamEqn x} = noExtCon x+p_tyFamInstEqn (XHsImplicitBndrs x) = noExtCon x ---------------------------------------------------------------------------- -- Helpers
src/Ormolu/Printer/Meat/Declaration/Value.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-} module Ormolu.Printer.Meat.Declaration.Value ( p_valDecl,@@ -20,7 +21,7 @@ import Data.Data hiding (Infix, Prefix) import Data.Functor ((<&>)) import Data.List (intersperse, sortOn)-import Data.List.NonEmpty ((<|), NonEmpty ((:|)))+import Data.List.NonEmpty ((<|), NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Text (Text) import qualified Data.Text as Text@@ -34,8 +35,6 @@ import Ormolu.Printer.Meat.Type import Ormolu.Printer.Operators import Ormolu.Utils-import RdrName (RdrName (..), rdrNameOcc)-import SrcLoc (combineSrcSpans, isOneLineSpan) -- | Style of a group of equations. data MatchGroupStyle@@ -65,12 +64,12 @@ p_valDecl :: HsBindLR GhcPs GhcPs -> R () p_valDecl = \case- FunBind NoExt funId funMatches _ _ -> p_funBind funId funMatches- PatBind NoExt pat grhss _ -> p_match PatternBind False NoSrcStrict [pat] grhss+ FunBind NoExtField funId funMatches _ _ -> p_funBind funId funMatches+ PatBind NoExtField 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 NoExt psb -> p_patSynBind psb- XHsBindsLR NoExt -> notImplemented "XHsBindsLR"+ PatSynBind NoExtField psb -> p_patSynBind psb+ XHsBindsLR x -> noExtCon x p_funBind :: Located RdrName ->@@ -114,8 +113,8 @@ (matchStrictness m) m_pats m_grhss- p_Match _ = notImplemented "XMatch"-p_matchGroup' _ _ _ (XMatchGroup NoExt) = notImplemented "XMatchGroup"+ p_Match (XMatch x) = noExtCon x+p_matchGroup' _ _ _ (XMatchGroup x) = noExtCon x -- | Function id obtained through pattern matching on 'FunBind' should not -- be used to print the actual equations because the different ‘RdrNames’@@ -193,14 +192,14 @@ then id else inci switchLayout [combinedSpans] $ do- let stdCase = sep breakpoint p_pat m_pats+ let stdCase = sep breakpoint (located' p_pat) m_pats case style of Function name -> p_infixDefHelper isInfix inci' (p_rdrName name)- (p_pat <$> m_pats)+ (located' p_pat <$> m_pats) PatternBind -> stdCase Case -> stdCase Lambda -> do@@ -266,7 +265,7 @@ switchLayout [patGrhssSpan] $ placeHanging placement p_body inci p_where-p_match' _ _ _ _ _ _ XGRHSs {} = notImplemented "XGRHSs"+p_match' _ _ _ _ _ _ (XGRHSs x) = noExtCon x p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R () p_grhs = p_grhs' exprPlacement p_hsExpr@@ -280,7 +279,7 @@ GroupStyle -> GRHS GhcPs (Located body) -> R ()-p_grhs' placer render style (GRHS NoExt guards body) =+p_grhs' placer render style (GRHS NoExtField guards body) = case guards of [] -> p_body xs -> do@@ -305,54 +304,55 @@ Nothing -> Nothing Just gs -> (Just . srcSpanEnd . getLoc . NE.last) gs p_body = located body render-p_grhs' _ _ _ (XGRHS NoExt) = notImplemented "XGRHS"+p_grhs' _ _ _ (XGRHS x) = noExtCon x p_hsCmd :: HsCmd GhcPs -> R () p_hsCmd = \case- HsCmdArrApp NoExt body input arrType _ -> do+ HsCmdArrApp NoExtField body input arrType _ -> do located body p_hsExpr- space- case arrType of- HsFirstOrderApp -> txt "-<"- HsHigherOrderApp -> txt "-<<"- placeHanging (exprPlacement (unLoc input)) $- located input p_hsExpr- HsCmdArrForm NoExt form Prefix _ cmds -> banana $ sitcc $ do+ breakpoint+ inci $ do+ case arrType of+ HsFirstOrderApp -> txt "-<"+ HsHigherOrderApp -> txt "-<<"+ placeHanging (exprPlacement (unLoc input)) $+ located input p_hsExpr+ HsCmdArrForm NoExtField form Prefix _ cmds -> banana $ sitcc $ do located form p_hsExpr unless (null cmds) $ do breakpoint inci (sequence_ (intersperse breakpoint (located' p_hsCmdTop <$> cmds)))- HsCmdArrForm NoExt form Infix _ [left, right] -> do+ HsCmdArrForm NoExtField form Infix _ [left, right] -> do located left p_hsCmdTop space located form p_hsExpr placeHanging (cmdTopPlacement (unLoc right)) $ located right p_hsCmdTop- HsCmdArrForm NoExt _ Infix _ _ -> notImplemented "HsCmdArrForm"+ HsCmdArrForm NoExtField _ Infix _ _ -> notImplemented "HsCmdArrForm" HsCmdApp {} -> -- XXX Does this ever occur in the syntax tree? It does not seem like it -- does. Open an issue and ping @yumiova if this ever occurs in output. notImplemented "HsCmdApp"- HsCmdLam NoExt mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup- HsCmdPar NoExt c -> parens N (located c p_hsCmd)- HsCmdCase NoExt e mgroup ->+ HsCmdLam NoExtField mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup+ HsCmdPar NoExtField c -> parens N (located c p_hsCmd)+ HsCmdCase NoExtField e mgroup -> p_case cmdPlacement p_hsCmd e mgroup- HsCmdIf NoExt _ if' then' else' ->+ HsCmdIf NoExtField _ if' then' else' -> p_if cmdPlacement p_hsCmd if' then' else'- HsCmdLet NoExt localBinds c ->+ HsCmdLet NoExtField localBinds c -> p_let p_hsCmd localBinds c- HsCmdDo NoExt es -> do+ HsCmdDo NoExtField es -> do txt "do" newline inci . located es $ sitcc . sep newline (located' (sitcc . p_stmt' cmdPlacement p_hsCmd)) HsCmdWrap {} -> notImplemented "HsCmdWrap"- XCmd {} -> notImplemented "XCmd"+ XCmd x -> noExtCon x p_hsCmdTop :: HsCmdTop GhcPs -> R () p_hsCmdTop = \case- HsCmdTop NoExt cmd -> located cmd p_hsCmd- XCmdTop {} -> notImplemented "XHsCmdTop"+ HsCmdTop NoExtField cmd -> located cmd p_hsCmd+ XCmdTop x -> noExtCon x p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R () p_stmt = p_stmt' exprPlacement p_hsExpr@@ -367,16 +367,13 @@ Stmt GhcPs (Located body) -> R () p_stmt' placer render = \case- LastStmt NoExt body _ _ -> located body render- BindStmt NoExt p f _ _ -> do- p_pat p+ LastStmt NoExtField body _ _ -> located body render+ BindStmt NoExtField p f _ _ -> do+ located p p_pat space txt "<-"- -- https://gitlab.haskell.org/ghc/ghc/issues/17330- let loc = case p of- XPat pat -> getLoc pat- _ -> error "p_stmt': BindStmt: Pat does not contain a location"- let placement =+ let loc = getLoc p+ placement = case f of L l' x -> if isOneLineSpan@@ -386,8 +383,8 @@ switchLayout [loc, getLoc f] $ placeHanging placement (located f render) ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer- BodyStmt NoExt body _ _ -> located body render- LetStmt NoExt binds -> do+ BodyStmt NoExtField body _ _ -> located body render+ LetStmt NoExtField binds -> do txt "let" space sitcc $ located binds p_hsLocalBinds@@ -429,10 +426,10 @@ txt "rec" space sitcc $ sepSemi (located' (p_stmt' placer render)) recS_stmts- XStmtLR {} -> notImplemented "XStmtLR"+ XStmtLR c -> noExtCon c gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]-gatherStmt (L _ (ParStmt NoExt block _ _)) =+gatherStmt (L _ (ParStmt NoExtField block _ _)) = foldr ((<>) . gatherStmtBlock) [] block gatherStmt (L s stmt@TransStmt {..}) = foldr liftAppend [] ((gatherStmt <$> trS_stmts) <> pure [[L s stmt]])@@ -441,11 +438,11 @@ gatherStmtBlock :: ParStmtBlock GhcPs GhcPs -> [[ExprLStmt GhcPs]] gatherStmtBlock (ParStmtBlock _ stmts _ _) = foldr (liftAppend . gatherStmt) [] stmts-gatherStmtBlock XParStmtBlock {} = notImplemented "XParStmtBlock"+gatherStmtBlock (XParStmtBlock x) = noExtCon x p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R () p_hsLocalBinds = \case- HsValBinds NoExt (ValBinds NoExt bag lsigs) -> do+ HsValBinds NoExtField (ValBinds NoExtField bag lsigs) -> do let ssStart = either (srcSpanStart . getLoc)@@ -467,20 +464,23 @@ sepSemi (\(m, i) -> (if m then br else id) $ p_item i) (markInit $ sortOn ssStart items)- HsValBinds NoExt _ -> notImplemented "HsValBinds"- HsIPBinds NoExt (IPBinds NoExt xs) ->+ HsValBinds NoExtField _ -> notImplemented "HsValBinds"+ HsIPBinds NoExtField (IPBinds NoExtField xs) -> -- Second argument of IPBind is always Left before type-checking.- let p_ipBind (IPBind NoExt (Left name) expr) = do+ let p_ipBind (IPBind NoExtField (Left name) expr) = do atom name space txt "=" breakpoint useBraces $ inci $ located expr p_hsExpr- p_ipBind _ = notImplemented "XHsIPBinds"+ p_ipBind (IPBind NoExtField (Right _) _) =+ -- Should only occur after the type checker+ notImplemented "IPBind _ (Right _) _"+ p_ipBind (XIPBind x) = noExtCon x in sepSemi (located' p_ipBind) xs- HsIPBinds NoExt _ -> notImplemented "HsIpBinds"- EmptyLocalBinds NoExt -> return ()- XHsLocalBindsLR _ -> notImplemented "XHsLocalBindsLR"+ HsIPBinds NoExtField _ -> notImplemented "HsIpBinds"+ EmptyLocalBinds NoExtField -> return ()+ XHsLocalBindsLR x -> noExtCon x p_hsRecField :: HsRecField' RdrName (LHsExpr GhcPs) ->@@ -495,42 +495,42 @@ p_hsTupArg :: HsTupArg GhcPs -> R () p_hsTupArg = \case- Present NoExt x -> located x p_hsExpr- Missing NoExt -> pure ()- XTupArg {} -> notImplemented "XTupArg"+ Present NoExtField x -> located x p_hsExpr+ Missing NoExtField -> pure ()+ XTupArg x -> noExtCon x p_hsExpr :: HsExpr GhcPs -> R () p_hsExpr = p_hsExpr' N p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R () p_hsExpr' s = \case- HsVar NoExt name -> p_rdrName name- HsUnboundVar NoExt _ -> notImplemented "HsUnboundVar"- HsConLikeOut NoExt _ -> notImplemented "HsConLikeOut"- HsRecFld NoExt x ->+ HsVar NoExtField name -> p_rdrName name+ HsUnboundVar NoExtField v -> atom (unboundVarOcc v)+ HsConLikeOut NoExtField _ -> notImplemented "HsConLikeOut"+ HsRecFld NoExtField x -> case x of- Unambiguous NoExt name -> p_rdrName name- Ambiguous NoExt name -> p_rdrName name- XAmbiguousFieldOcc NoExt -> notImplemented "XAmbiguousFieldOcc"- HsOverLabel NoExt _ v -> do+ Unambiguous NoExtField name -> p_rdrName name+ Ambiguous NoExtField name -> p_rdrName name+ XAmbiguousFieldOcc xx -> noExtCon xx+ HsOverLabel NoExtField _ v -> do txt "#" atom v- HsIPVar NoExt (HsIPName name) -> do+ HsIPVar NoExtField (HsIPName name) -> do txt "?" atom name- HsOverLit NoExt v -> atom (ol_val v)- HsLit NoExt lit ->+ HsOverLit NoExtField v -> atom (ol_val v)+ HsLit NoExtField lit -> case lit of HsString (SourceText stxt) _ -> p_stringLit stxt HsStringPrim (SourceText stxt) _ -> p_stringLit stxt r -> atom r- HsLam NoExt mgroup ->+ HsLam NoExtField mgroup -> p_matchGroup Lambda mgroup- HsLamCase NoExt mgroup -> do+ HsLamCase NoExtField mgroup -> do txt "\\case" breakpoint inci (p_matchGroup LambdaCase mgroup)- HsApp NoExt f x -> do+ HsApp NoExtField 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.@@ -564,9 +564,9 @@ -- expression is parenthesised. indent = case func of- L _ (HsPar NoExt _) -> inci- L _ (HsAppType NoExt _ _) -> inci- L _ (HsMultiIf NoExt _) -> inci+ L _ (HsPar NoExtField _) -> inci+ L _ (HsAppType NoExtField _ _) -> inci+ L _ (HsMultiIf NoExtField _) -> inci L spn _ -> if isOneLineSpan spn then inci@@ -588,35 +588,35 @@ sep breakpoint (located' p_hsExpr) initp placeHanging placement $ located lastp p_hsExpr- HsAppType NoExt e a -> do+ HsAppType NoExtField e a -> do located e p_hsExpr breakpoint inci $ do txt "@" located (hswc_body a) p_hsType- OpApp NoExt x op y -> do+ OpApp NoExtField x op y -> do let opTree = OpBranch (exprOpTree x) op (exprOpTree y) p_exprOpTree True s (reassociateOpTree getOpName opTree)- NegApp NoExt e _ -> do+ NegApp NoExtField e _ -> do txt "-" space located e p_hsExpr- HsPar NoExt e ->+ HsPar NoExtField e -> parens s (located e (dontUseBraces . p_hsExpr))- SectionL NoExt x op -> do+ SectionL NoExtField x op -> do located x p_hsExpr breakpoint inci (located op p_hsExpr)- SectionR NoExt op x -> do+ SectionR NoExtField op x -> do located op p_hsExpr useRecordDot' <- useRecordDot let isRecordDot' = isRecordDot (unLoc op) (getLoc x) unless (useRecordDot' && isRecordDot') breakpoint inci (located x p_hsExpr)- ExplicitTuple NoExt args boxity -> do+ ExplicitTuple NoExtField args boxity -> do let isSection = any (isMissing . unLoc) args isMissing = \case- Missing NoExt -> True+ Missing NoExtField -> True _ -> False let parens' = case boxity of@@ -629,18 +629,18 @@ else switchLayout (getLoc <$> args) . parens' s . sitcc $ sep (comma >> breakpoint) (sitcc . located' p_hsTupArg) args- ExplicitSum NoExt tag arity e ->+ ExplicitSum NoExtField tag arity e -> p_unboxedSum N tag arity (located e p_hsExpr)- HsCase NoExt e mgroup ->+ HsCase NoExtField e mgroup -> p_case exprPlacement p_hsExpr e mgroup- HsIf NoExt _ if' then' else' ->+ HsIf NoExtField _ if' then' else' -> p_if exprPlacement p_hsExpr if' then' else'- HsMultiIf NoExt guards -> do+ HsMultiIf NoExtField guards -> do txt "if " inci . inci . sitcc $ sep newline (located' (p_grhs RightArrow)) guards- HsLet NoExt localBinds e ->+ HsLet NoExtField localBinds e -> p_let p_hsExpr localBinds e- HsDo NoExt ctx es -> do+ HsDo NoExtField ctx es -> do let doBody header = do txt header breakpoint@@ -685,10 +685,10 @@ breakpoint let HsRecFields {..} = rcon_flds updName f =- f+ (f :: HsRecField GhcPs (LHsExpr GhcPs)) { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of FieldOcc _ n -> n- XFieldOcc _ -> notImplemented "XFieldOcc"+ XFieldOcc x -> noExtCon x } fields = located' (p_hsRecField . updName) <$> rec_flds dotdot =@@ -708,27 +708,26 @@ == (srcSpanStartCol <$> mrs (head rupd_flds)) unless (useRecordDot' && isPluginForm) breakpoint let updName f =- f+ (f :: HsRecUpdField GhcPs) { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of Ambiguous _ n -> n Unambiguous _ n -> n- XAmbiguousFieldOcc _ -> notImplemented "XAmbiguousFieldOcc"+ XAmbiguousFieldOcc x -> noExtCon x } inci . braces N . sitcc $ sep (comma >> breakpoint) (sitcc . located' (p_hsRecField . updName)) rupd_flds- ExprWithTySig NoExt x HsWC {hswc_body = HsIB {..}} -> sitcc $ do+ ExprWithTySig NoExtField x HsWC {hswc_body = HsIB {..}} -> sitcc $ do located x p_hsExpr space txt "::" breakpoint inci $ located hsib_body p_hsType- ExprWithTySig NoExt _ HsWC {hswc_body = XHsImplicitBndrs {}} ->- notImplemented "XHsImplicitBndrs"- ExprWithTySig NoExt _ XHsWildCardBndrs {} -> notImplemented "XHsWildCardBndrs"- ArithSeq NoExt _ x ->+ ExprWithTySig NoExtField _ HsWC {hswc_body = XHsImplicitBndrs x} -> noExtCon x+ ExprWithTySig NoExtField _ (XHsWildCardBndrs x) -> noExtCon x+ ArithSeq NoExtField _ x -> case x of From from -> brackets s . sitcc $ do located from p_hsExpr@@ -750,25 +749,25 @@ txt ".." space located to p_hsExpr- HsSCC NoExt _ name x -> do+ HsSCC NoExtField _ name x -> do txt "{-# SCC " atom name txt " #-}" breakpoint located x p_hsExpr- HsCoreAnn NoExt _ value x -> do+ HsCoreAnn NoExtField _ value x -> do txt "{-# CORE " atom value txt " #-}" breakpoint located x p_hsExpr- HsBracket NoExt x -> p_hsBracket x+ HsBracket NoExtField x -> p_hsBracket x HsRnBracketOut {} -> notImplemented "HsRnBracketOut" HsTcBracketOut {} -> notImplemented "HsTcBracketOut"- HsSpliceE NoExt splice -> p_hsSplice splice- HsProc NoExt p e -> do+ HsSpliceE NoExtField splice -> p_hsSplice splice+ HsProc NoExtField p e -> do txt "proc"- locatedPat p $ \x -> do+ located p $ \x -> do breakpoint inci (p_pat x) breakpoint@@ -779,31 +778,11 @@ txt "static" breakpoint inci (located e p_hsExpr)- HsArrApp NoExt body input arrType cond ->- p_hsCmd (HsCmdArrApp NoExt body input arrType cond)- HsArrForm NoExt form mfixity cmds ->- p_hsCmd (HsCmdArrForm NoExt form Prefix mfixity cmds) HsTick {} -> notImplemented "HsTick" HsBinTick {} -> notImplemented "HsBinTick" HsTickPragma {} -> notImplemented "HsTickPragma"- -- These four constructs should never appear in correct programs.- -- See: https://github.com/tweag/ormolu/issues/343- EWildPat NoExt -> txt "_"- EAsPat NoExt n p -> do- p_rdrName n- txt "@"- located p p_hsExpr- EViewPat NoExt p e -> do- located p p_hsExpr- space- txt "->"- breakpoint- inci (located e p_hsExpr)- ELazyPat NoExt p -> do- txt "~"- located p p_hsExpr HsWrap {} -> notImplemented "HsWrap"- XExpr {} -> notImplemented "XExpr"+ XExpr x -> noExtCon x p_patSynBind :: PatSynBind GhcPs GhcPs -> R () p_patSynBind PSB {..} = do@@ -813,15 +792,15 @@ Unidirectional -> do txt "<-" breakpoint- p_pat psb_def+ located psb_def p_pat ImplicitBidirectional -> do txt "=" breakpoint- p_pat psb_def+ located psb_def p_pat ExplicitBidirectional mgroup -> do txt "<-" breakpoint- p_pat psb_def+ located psb_def p_pat newline txt "where" newline@@ -855,7 +834,7 @@ space p_rdrName r inci rhs-p_patSynBind (XPatSynBind NoExt) = notImplemented "XPatSynBind"+p_patSynBind (XPatSynBind x) = noExtCon x p_case :: Data body =>@@ -922,40 +901,37 @@ p_pat :: Pat GhcPs -> R () p_pat = \case- -- Note: starting from GHC 8.8, 'LPat' == 'Pat'. Located 'Pat's are always- -- constructed with the 'XPat' constructor, containing a @Located Pat@.- XPat pat -> located pat p_pat- WildPat NoExt -> txt "_"- VarPat NoExt name -> p_rdrName name- LazyPat NoExt pat -> do+ WildPat NoExtField -> txt "_"+ VarPat NoExtField name -> p_rdrName name+ LazyPat NoExtField pat -> do txt "~"- p_pat pat- AsPat NoExt name pat -> do+ located pat p_pat+ AsPat NoExtField name pat -> do p_rdrName name txt "@"- p_pat pat- ParPat NoExt pat ->- locatedPat pat (parens S . p_pat)- BangPat NoExt pat -> do+ located pat p_pat+ ParPat NoExtField pat ->+ located pat (parens S . p_pat)+ BangPat NoExtField pat -> do txt "!"- p_pat pat- ListPat NoExt pats ->- brackets S . sitcc $ sep (comma >> breakpoint) p_pat pats- TuplePat NoExt pats boxing -> do+ located pat p_pat+ ListPat NoExtField pats ->+ brackets S . sitcc $ sep (comma >> breakpoint) (located' p_pat) pats+ TuplePat NoExtField pats boxing -> do let f = case boxing of Boxed -> parens S Unboxed -> parensHash S- f . sitcc $ sep (comma >> breakpoint) (sitcc . p_pat) pats- SumPat NoExt pat tag arity ->- p_unboxedSum S tag arity (p_pat pat)+ f . sitcc $ sep (comma >> breakpoint) (sitcc . located' p_pat) pats+ SumPat NoExtField pat tag arity ->+ p_unboxedSum S tag arity (located pat p_pat) ConPatIn pat details -> case details of PrefixCon xs -> sitcc $ do p_rdrName pat unless (null xs) $ do breakpoint- inci . sitcc $ sep breakpoint (sitcc . p_pat) xs+ inci . sitcc $ sep breakpoint (sitcc . located' p_pat) xs RecCon (HsRecFields fields dotdot) -> do p_rdrName pat breakpoint@@ -965,34 +941,37 @@ inci . braces N . sitcc . sep (comma >> breakpoint) f $ case dotdot of Nothing -> Just <$> fields- Just n -> (Just <$> take n fields) ++ [Nothing]- InfixCon x y -> do- p_pat x- space- p_rdrName pat- breakpoint- inci (p_pat y)+ Just (L _ n) -> (Just <$> take n fields) ++ [Nothing]+ InfixCon l r -> do+ switchLayout [getLoc l, getLoc r] $ do+ located l p_pat+ breakpoint+ inci $ do+ p_rdrName pat+ space+ located r p_pat ConPatOut {} -> notImplemented "ConPatOut" -- presumably created by renamer?- ViewPat NoExt expr pat -> sitcc $ do+ ViewPat NoExtField expr pat -> sitcc $ do located expr p_hsExpr space txt "->" breakpoint- inci (p_pat pat)- SplicePat NoExt splice -> p_hsSplice splice- LitPat NoExt p -> atom p- NPat NoExt v _ _ -> located v (atom . ol_val)- NPlusKPat NoExt n k _ _ _ -> sitcc $ do+ inci (located pat p_pat)+ SplicePat NoExtField splice -> p_hsSplice splice+ LitPat NoExtField p -> atom p+ NPat NoExtField v _ _ -> located v (atom . ol_val)+ NPlusKPat NoExtField n k _ _ _ -> sitcc $ do p_rdrName n breakpoint inci $ do txt "+" space located k (atom . ol_val)- SigPat NoExt pat hswc -> do- p_pat pat+ SigPat NoExtField pat hswc -> do+ located pat p_pat p_typeAscription hswc CoPat {} -> notImplemented "CoPat" -- apparently created at some later stage+ XPat x -> noExtCon x p_pat_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R () p_pat_hsRecField HsRecField {..} = do@@ -1002,7 +981,7 @@ space txt "=" breakpoint- inci (p_pat hsRecFieldArg)+ inci (located hsRecFieldArg p_pat) p_unboxedSum :: BracketStyle -> ConTag -> Arity -> R () -> R () p_unboxedSum s tag arity m = do@@ -1023,9 +1002,9 @@ p_hsSplice :: HsSplice GhcPs -> R () p_hsSplice = \case- HsTypedSplice NoExt deco _ expr -> p_hsSpliceTH True expr deco- HsUntypedSplice NoExt deco _ expr -> p_hsSpliceTH False expr deco- HsQuasiQuote NoExt _ quoterName srcSpan str -> do+ HsTypedSplice NoExtField deco _ expr -> p_hsSpliceTH True expr deco+ HsUntypedSplice NoExtField deco _ expr -> p_hsSpliceTH False expr deco+ HsQuasiQuote NoExtField _ quoterName srcSpan str -> do txt "[" p_rdrName (L srcSpan quoterName) txt "|"@@ -1035,7 +1014,7 @@ txt "|]" HsSpliced {} -> notImplemented "HsSpliced" HsSplicedT {} -> notImplemented "HsSplicedT"- XSplice {} -> notImplemented "XSplice"+ XSplice x -> noExtCon x p_hsSpliceTH :: -- | Typed splice?@@ -1059,17 +1038,17 @@ p_hsBracket :: HsBracket GhcPs -> R () p_hsBracket = \case- ExpBr NoExt expr -> do+ ExpBr NoExtField expr -> do anns <- getEnclosingAnns let name = case anns of AnnOpenEQ : _ -> "" _ -> "e" quote name (located expr p_hsExpr)- PatBr NoExt pat -> quote "p" (p_pat pat)- DecBrL NoExt decls -> quote "d" (p_hsDecls Free decls)- DecBrG NoExt _ -> notImplemented "DecBrG" -- result of renamer- TypBr NoExt ty -> quote "t" (located ty p_hsType)- VarBr NoExt isSingleQuote name -> do+ PatBr NoExtField pat -> located pat (quote "p" . p_pat)+ DecBrL NoExtField decls -> quote "d" (p_hsDecls Free decls)+ DecBrG NoExtField _ -> notImplemented "DecBrG" -- result of renamer+ TypBr NoExtField ty -> quote "t" (located ty p_hsType)+ VarBr NoExtField 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@@ -1084,13 +1063,13 @@ && not (doesNotNeedExtraParens name) wrapper = if isOperator then parens N else id wrapper $ p_rdrName (noLoc name)- TExpBr NoExt expr -> do+ TExpBr NoExtField expr -> do txt "[||" breakpoint' located expr p_hsExpr breakpoint' txt "||]"- XBracket {} -> notImplemented "XBracket"+ XBracket x -> noExtCon x where quote :: Text -> R () -> R () quote name body = do@@ -1169,9 +1148,9 @@ liftAppend (x : xs) (y : ys) = x <> y : liftAppend xs ys getGRHSSpan :: GRHS GhcPs (Located body) -> SrcSpan-getGRHSSpan (GRHS NoExt guards body) =+getGRHSSpan (GRHS NoExtField guards body) = combineSrcSpans' $ getLoc body :| map getLoc guards-getGRHSSpan (XGRHS NoExt) = notImplemented "XGRHS"+getGRHSSpan (XGRHS x) = noExtCon x -- | Place a thing that may have a hanging form. This function handles how -- to separate it from preceding expressions and whether to bump indentation@@ -1192,67 +1171,63 @@ (body -> Placement) -> [LGRHS GhcPs (Located body)] -> Placement-blockPlacement placer [L _ (GRHS NoExt _ (L _ x))] = placer x+blockPlacement placer [L _ (GRHS NoExtField _ (L _ x))] = placer x blockPlacement _ _ = Normal -- | Check if given command has a hanging form. cmdPlacement :: HsCmd GhcPs -> Placement cmdPlacement = \case- HsCmdLam NoExt _ -> Hanging- HsCmdCase NoExt _ _ -> Hanging- HsCmdDo NoExt _ -> Hanging+ HsCmdLam NoExtField _ -> Hanging+ HsCmdCase NoExtField _ _ -> Hanging+ HsCmdDo NoExtField _ -> Hanging _ -> Normal cmdTopPlacement :: HsCmdTop GhcPs -> Placement cmdTopPlacement = \case- HsCmdTop NoExt (L _ x) -> cmdPlacement x- XCmdTop {} -> notImplemented "XCmdTop"+ HsCmdTop NoExtField (L _ x) -> cmdPlacement x+ XCmdTop x -> noExtCon x -- | Check if given expression has a hanging form. exprPlacement :: HsExpr GhcPs -> Placement exprPlacement = \case -- Only hang lambdas with single line parameter lists- HsLam NoExt mg -> case mg of- MG _ (L _ [L _ (Match NoExt _ (x : xs) _)]) _+ HsLam NoExtField mg -> case mg of+ MG _ (L _ [L _ (Match NoExtField _ (x : xs) _)]) _ | isOneLineSpan (combineSrcSpans' $ fmap getLoc (x :| xs)) -> Hanging _ -> Normal- HsLamCase NoExt _ -> Hanging- HsCase NoExt _ _ -> Hanging- HsDo NoExt DoExpr _ -> Hanging- HsDo NoExt MDoExpr _ -> Hanging+ HsLamCase NoExtField _ -> Hanging+ HsCase NoExtField _ _ -> Hanging+ HsDo NoExtField DoExpr _ -> Hanging+ HsDo NoExtField MDoExpr _ -> Hanging -- If the rightmost expression in an operator chain is hanging, make the -- whole block hanging; so that we can use the common @f = foo $ do@ -- style.- OpApp NoExt _ _ y -> exprPlacement (unLoc y)+ OpApp NoExtField _ _ y -> exprPlacement (unLoc y) -- Same thing for function applications (usually with -XBlockArguments)- HsApp NoExt _ y -> exprPlacement (unLoc y)- HsProc NoExt p _ ->- -- https://gitlab.haskell.org/ghc/ghc/issues/17330- let loc = case p of- XPat pat -> getLoc pat- _ -> error "exprPlacement: HsProc: Pat does not contain a location"- in -- Indentation breaks if pattern is longer than one line and left- -- hanging. Consequently, only apply hanging when it is safe.- if isOneLineSpan loc- then Hanging- else Normal+ HsApp NoExtField _ y -> exprPlacement (unLoc y)+ HsProc NoExtField 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)+ then Hanging+ else Normal _ -> Normal withGuards :: [LGRHS GhcPs (Located body)] -> Bool withGuards = any (checkOne . unLoc) where checkOne :: GRHS GhcPs (Located body) -> Bool- checkOne (GRHS NoExt [] _) = False+ checkOne (GRHS NoExtField [] _) = False checkOne _ = True exprOpTree :: LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)-exprOpTree (L _ (OpApp NoExt x op y)) = OpBranch (exprOpTree x) op (exprOpTree y)+exprOpTree (L _ (OpApp NoExtField x op y)) = OpBranch (exprOpTree x) op (exprOpTree y) exprOpTree n = OpNode n getOpName :: HsExpr GhcPs -> Maybe RdrName getOpName = \case- HsVar NoExt (L _ a) -> Just a+ HsVar NoExtField (L _ a) -> Just a _ -> Nothing p_exprOpTree ::@@ -1274,8 +1249,10 @@ OpNode (L _ n) -> exprPlacement n _ -> Normal else Normal+ -- Distinguish holes used in infix notation.+ -- eg. '1 _foo 2' and '1 `_foo` 2' opWrapper = case unLoc op of- EWildPat NoExt -> backticks+ HsUnboundVar NoExtField _ -> backticks _ -> id layout <- getLayout let ub = case layout of@@ -1330,7 +1307,7 @@ SrcSpan -> Bool isRecordDot op (RealSrcSpan ySpan) = case op of- HsVar NoExt (L (RealSrcSpan opSpan) opName) ->+ HsVar NoExtField (L (RealSrcSpan opSpan) opName) -> isDot opName && (srcSpanEndCol opSpan == srcSpanStartCol ySpan) _ -> False isRecordDot _ _ = False
src/Ormolu/Printer/Meat/Declaration/Warning.hs view
@@ -13,17 +13,16 @@ import GHC import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common-import Ormolu.Utils p_warnDecls :: WarnDecls GhcPs -> R ()-p_warnDecls (Warnings NoExt _ warnings) =+p_warnDecls (Warnings NoExtField _ warnings) = traverse_ (located' p_warnDecl) warnings-p_warnDecls XWarnDecls {} = notImplemented "XWarnDecls"+p_warnDecls (XWarnDecls x) = noExtCon x p_warnDecl :: WarnDecl GhcPs -> R ()-p_warnDecl (Warning NoExt functions warningTxt) =+p_warnDecl (Warning NoExtField functions warningTxt) = p_topLevelWarning functions warningTxt-p_warnDecl XWarnDecl {} = notImplemented "XWarnDecl"+p_warnDecl (XWarnDecl x) = noExtCon x p_moduleWarning :: WarningTxt -> R () p_moduleWarning wtxt = do
src/Ormolu/Printer/Meat/ImportExport.hs view
@@ -11,10 +11,8 @@ import Control.Monad import GHC-import HsImpExp (IE (..)) import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common-import Ormolu.Utils p_hsmodExports :: [LIE GhcPs] -> R () p_hsmodExports [] = do@@ -26,15 +24,17 @@ layout <- getLayout sep breakpoint (sitcc . located' (uncurry (p_lie layout))) (attachPositions xs) -p_hsmodImport :: ImportDecl GhcPs -> R ()-p_hsmodImport ImportDecl {..} = do+p_hsmodImport :: Bool -> ImportDecl GhcPs -> R ()+p_hsmodImport useQualifiedPost ImportDecl {..} = do txt "import" space when ideclSource (txt "{-# SOURCE #-}") space when ideclSafe (txt "safe") space- when ideclQualified (txt "qualified")+ when+ (isImportDeclQualified ideclQualified && not useQualifiedPost)+ (txt "qualified") space case ideclPkgQual of Nothing -> return ()@@ -42,6 +42,9 @@ space inci $ do located ideclName atom+ when+ (isImportDeclQualified ideclQualified && useQualifiedPost)+ (space >> txt "qualified") case ideclAs of Nothing -> return () Just l -> do@@ -62,22 +65,22 @@ layout <- getLayout sep breakpoint (sitcc . located' (uncurry (p_lie layout))) (attachPositions xs) newline-p_hsmodImport (XImportDecl NoExt) = notImplemented "XImportDecl"+p_hsmodImport _ (XImportDecl x) = noExtCon x p_lie :: Layout -> (Int, Int) -> IE GhcPs -> R () p_lie encLayout (i, totalItems) = \case- IEVar NoExt l1 -> do+ IEVar NoExtField l1 -> do located l1 p_ieWrappedName p_comma- IEThingAbs NoExt l1 -> do+ IEThingAbs NoExtField l1 -> do located l1 p_ieWrappedName p_comma- IEThingAll NoExt l1 -> do+ IEThingAll NoExtField l1 -> do located l1 p_ieWrappedName space txt "(..)" p_comma- IEThingWith NoExt l1 w xs _ -> sitcc $ do+ IEThingWith NoExtField l1 w xs _ -> sitcc $ do located l1 p_ieWrappedName breakpoint inci $ do@@ -91,16 +94,16 @@ let (before, after) = splitAt n names in before ++ [txt ".."] ++ after p_comma- IEModuleContents NoExt l1 -> do+ IEModuleContents NoExtField l1 -> do located l1 p_hsmodName p_comma- IEGroup NoExt n str -> do+ IEGroup NoExtField n str -> do unless (i == 0) newline p_hsDocString (Asterisk n) False (noLoc str)- IEDoc NoExt str ->+ IEDoc NoExtField str -> p_hsDocString Pipe False (noLoc str)- IEDocNamed NoExt str -> p_hsDocName str- XIE NoExt -> notImplemented "XIE"+ IEDocNamed NoExtField str -> p_hsDocName str+ XIE x -> noExtCon x where p_comma = case encLayout of
src/Ormolu/Printer/Meat/Module.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -26,10 +27,12 @@ [Located String] -> -- | Pragmas [Pragma] ->+ -- | Whether to use postfix qualified imports+ Bool -> -- | AST to print ParsedSource -> R ()-p_hsModule shebangs pragmas (L moduleSpan HsModule {..}) = do+p_hsModule shebangs pragmas qualifiedPost (L moduleSpan HsModule {..}) = do -- If span of exports in multiline, the whole thing is multiline. This is -- especially important because span of module itself always seems to have -- length zero, so it's not reliable for layout selection.@@ -63,7 +66,7 @@ txt "where" newline newline- forM_ (sortImports hsmodImports) (located' p_hsmodImport)+ forM_ (sortImports hsmodImports) (located' (p_hsmodImport qualifiedPost)) newline switchLayout (getLoc <$> hsmodDecls) $ do p_hsDecls Free hsmodDecls
src/Ormolu/Printer/Meat/Type.hs view
@@ -27,11 +27,11 @@ p_hsType' :: Bool -> HsType GhcPs -> R () p_hsType' multilineArgs = \case- HsForAllTy NoExt bndrs t -> do- p_forallBndrs p_hsTyVarBndr bndrs+ HsForAllTy NoExtField visibility bndrs t -> do+ p_forallBndrs visibility p_hsTyVarBndr bndrs interArgBreak p_hsType' multilineArgs (unLoc t)- HsQualTy NoExt qs t -> do+ HsQualTy NoExtField qs t -> do located qs p_hsContext space txt "=>"@@ -40,7 +40,7 @@ HsQualTy {} -> p_hsTypeR (unLoc t) HsFunTy {} -> p_hsTypeR (unLoc t) _ -> located t p_hsTypeR- HsTyVar NoExt p n -> do+ HsTyVar NoExtField p n -> do case p of IsPromoted -> do txt "'"@@ -49,10 +49,20 @@ _ -> return () NotPromoted -> return () p_rdrName n- HsAppTy NoExt f x -> sitcc $ do- located f p_hsType- breakpoint- inci (located x p_hsType)+ HsAppTy NoExtField 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.+ gatherArgs f' knownArgs =+ case f' of+ L _ (HsAppTy _ l r) -> gatherArgs l (r : knownArgs)+ _ -> (f', knownArgs)+ (func, args) = gatherArgs f [x]+ switchLayout (getLoc f : fmap getLoc args) $ sitcc $ do+ located func p_hsType+ breakpoint+ inci $+ sep breakpoint (located' p_hsType) args HsAppKindTy _ ty kd -> sitcc $ do -- The first argument is the location of the "@..." part. Not 100% sure, -- but I think we can ignore it as long as we use 'located' on both the@@ -62,7 +72,7 @@ inci $ do txt "@" located kd p_hsType- HsFunTy NoExt x y@(L _ y') -> do+ HsFunTy NoExtField x y@(L _ y') -> do located x p_hsType space txt "->"@@ -70,9 +80,9 @@ case y' of HsFunTy {} -> p_hsTypeR y' _ -> located y p_hsTypeR- HsListTy NoExt t ->+ HsListTy NoExtField t -> located t (brackets N . p_hsType)- HsTupleTy NoExt tsort xs ->+ HsTupleTy NoExtField tsort xs -> let parens' = case tsort of HsUnboxedTuple -> parensHash N@@ -81,33 +91,33 @@ HsBoxedOrConstraintTuple -> parens N in parens' . sitcc $ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs- HsSumTy NoExt xs ->+ HsSumTy NoExtField xs -> parensHash N . sitcc $ sep (txt "|" >> breakpoint) (sitcc . located' p_hsType) xs- HsOpTy NoExt x op y ->+ HsOpTy NoExtField x op y -> sitcc $ let opTree = OpBranch (tyOpTree x) op (tyOpTree y) in p_tyOpTree (reassociateOpTree Just opTree)- HsParTy NoExt t ->+ HsParTy NoExtField t -> parens N (located t p_hsType)- HsIParamTy NoExt n t -> sitcc $ do+ HsIParamTy NoExtField n t -> sitcc $ do located n atom space txt "::" breakpoint inci (located t p_hsType)- HsStarTy NoExt _ -> txt "*"- HsKindSig NoExt t k -> sitcc $ do+ HsStarTy NoExtField _ -> txt "*"+ HsKindSig NoExtField t k -> sitcc $ do located t p_hsType space -- FIXME txt "::" space inci (located k p_hsType)- HsSpliceTy NoExt splice -> p_hsSplice splice- HsDocTy NoExt t str -> do+ HsSpliceTy NoExtField splice -> p_hsSplice splice+ HsDocTy NoExtField t str -> do p_hsDocString Pipe True str located t p_hsType- HsBangTy NoExt (HsSrcBang _ u s) t -> do+ HsBangTy NoExtField (HsSrcBang _ u s) t -> do case u of SrcUnpack -> txt "{-# UNPACK #-}" >> space SrcNoUnpack -> txt "{-# NOUNPACK #-}" >> space@@ -117,9 +127,9 @@ SrcStrict -> txt "!" NoSrcStrict -> return () located t p_hsType- HsRecTy NoExt fields ->+ HsRecTy NoExtField fields -> p_conDeclFields fields- HsExplicitListTy NoExt p xs -> do+ HsExplicitListTy NoExtField p xs -> do case p of IsPromoted -> txt "'" NotPromoted -> return ()@@ -130,18 +140,18 @@ (IsPromoted, L _ t : _) | isPromoted t -> space _ -> return () sitcc $ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs- HsExplicitTupleTy NoExt xs -> do+ HsExplicitTupleTy NoExtField xs -> do txt "'" parens N $ do case xs of L _ t : _ | isPromoted t -> space _ -> return () sep (comma >> breakpoint) (located' p_hsType) xs- HsTyLit NoExt t ->+ HsTyLit NoExtField t -> case t of HsStrTy (SourceText s) _ -> p_stringLit s a -> atom a- HsWildCardTy NoExt -> txt "_"+ HsWildCardTy NoExtField -> txt "_" XHsType (NHsCoreTy t) -> atom t where isPromoted = \case@@ -173,26 +183,29 @@ p_hsTyVarBndr :: HsTyVarBndr GhcPs -> R () p_hsTyVarBndr = \case- UserTyVar NoExt x ->+ UserTyVar NoExtField x -> p_rdrName x- KindedTyVar NoExt l k -> parens N $ do+ KindedTyVar NoExtField l k -> parens N $ do located l atom space txt "::" breakpoint inci (located k p_hsType)- XTyVarBndr NoExt -> notImplemented "XTyVarBndr"+ XTyVarBndr x -> noExtCon x -- | Render several @forall@-ed variables.-p_forallBndrs :: Data a => (a -> R ()) -> [Located a] -> R ()-p_forallBndrs _ [] = txt "forall."-p_forallBndrs p tyvars =+p_forallBndrs :: Data a => ForallVisFlag -> (a -> R ()) -> [Located a] -> R ()+p_forallBndrs ForallInvis _ [] = txt "forall."+p_forallBndrs ForallVis _ [] = txt "forall ->"+p_forallBndrs vis p tyvars = switchLayout (getLoc <$> tyvars) $ do txt "forall" breakpoint inci $ do sitcc $ sep breakpoint (sitcc . located' p) tyvars- txt "."+ case vis of+ ForallInvis -> txt "."+ ForallVis -> space >> txt "->" p_conDeclFields :: [LConDeclField GhcPs] -> R () p_conDeclFields xs =@@ -211,10 +224,10 @@ txt "::" breakpoint sitcc . inci $ p_hsType (unLoc cd_fld_type)-p_conDeclField (XConDeclField NoExt) = notImplemented "XConDeclField"+p_conDeclField (XConDeclField x) = noExtCon x tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (Located RdrName)-tyOpTree (L _ (HsOpTy NoExt l op r)) =+tyOpTree (L _ (HsOpTy NoExtField l op r)) = OpBranch (tyOpTree l) op (tyOpTree r) tyOpTree n = OpNode n @@ -235,17 +248,17 @@ tyVarsToTypes :: LHsQTyVars GhcPs -> [LHsType GhcPs] tyVarsToTypes = \case HsQTvs {..} -> fmap tyVarToType <$> hsq_explicit- XLHsQTyVars {} -> notImplemented "XLHsQTyVars"+ XLHsQTyVars x -> noExtCon x tyVarToType :: HsTyVarBndr GhcPs -> HsType GhcPs tyVarToType = \case- UserTyVar NoExt tvar -> HsTyVar NoExt NotPromoted tvar- KindedTyVar NoExt tvar kind ->+ UserTyVar NoExtField tvar -> HsTyVar NoExtField NotPromoted tvar+ KindedTyVar NoExtField 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 NoExt $ noLoc $- HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted tvar)) kind- XTyVarBndr {} -> notImplemented "XTyVarBndr"+ HsParTy NoExtField $ noLoc $+ HsKindSig NoExtField (noLoc (HsTyVar NoExtField NotPromoted tvar)) kind+ XTyVarBndr x -> noExtCon x
src/Ormolu/Printer/Operators.hs view
@@ -10,16 +10,13 @@ ) where -import BasicTypes (Fixity (..), SourceText (NoSourceText), compareFixity, defaultFixity) import Data.Function (on)-import Data.List+import qualified Data.List as L import Data.Maybe (fromMaybe, mapMaybe) import Data.Ord (Down (Down), comparing) import GHC import OccName (mkVarOcc) import Ormolu.Utils (unSrcSpan)-import RdrName (mkRdrUnqual)-import SrcLoc (combineSrcSpans) -- | Intermediate representation of operator trees. It has two type -- parameters: @ty@ is the type of sub-expressions, while @op@ is the type@@ -108,7 +105,7 @@ buildFixityMap getOpName opTree = concatMap (\(i, ns) -> map (\(n, _) -> (n, fixity i InfixL)) ns) . zip [0 ..]- . groupBy (doubleWithinEps 0.00001 `on` snd)+ . L.groupBy (doubleWithinEps 0.00001 `on` snd) . (overrides ++) . modeScores $ score opTree@@ -146,22 +143,22 @@ -- Pick the most common score per 'RdrName'. modeScores :: [(RdrName, Double)] -> [(RdrName, Double)] modeScores =- sortOn snd+ L.sortOn snd . mapMaybe ( \case [] -> Nothing xs@((n, _) : _) -> Just (n, mode $ map snd xs) )- . groupBy ((==) `on` fst)- . sort+ . L.groupBy ((==) `on` fst)+ . L.sort -- Return the most common number, leaning to the smaller -- one in case of a tie. mode :: [Double] -> Double mode = head- . minimumBy (comparing (Down . length))- . groupBy (doubleWithinEps 0.0001)- . sort+ . L.minimumBy (comparing (Down . length))+ . L.groupBy (doubleWithinEps 0.0001)+ . L.sort -- The start column of the rightmost operator. maxCol = go opTree where
src/Ormolu/Utils.hs view
@@ -22,7 +22,7 @@ import Data.Text (Text) import qualified Data.Text as T import GHC-import HsDoc (HsDocString, unpackHDS)+import GHC.DynFlags (baseDynFlags) import qualified Outputable as GHC -- | Combine all source spans from the given list.@@ -39,7 +39,7 @@ -- | Pretty-print an 'GHC.Outputable' thing. showOutputable :: GHC.Outputable o => o -> String-showOutputable = GHC.showSDocUnsafe . GHC.ppr+showOutputable = GHC.showSDoc baseDynFlags . GHC.ppr -- | Split and normalize a doc string. The result is a list of lines that -- make up the comment.