b9c8b64 · ormolu · git.iko.soy

app/Main.hs+1−2

compare with master

unifiedsplit

@@ -79,8 +79,7 @@ optsParserInfo = info (helper <*> ver <*> optsParser) . mconcat $

79 , $gitBranch

80 , $gitHash

81 ]

82− , "using ghc-exactprint " ++ VERSION_ghc_exactprint

83− , "using ghc " ++ VERSION_ghc

82+ , "using ghc " ++ VERSION_ghc

84 ]

83 ]

85

84

86optsParser :: Parser Opts

85optsParser :: Parser Opts

data/examples/declaration/data/fat-multiline-out.hs−1

@@ -1,5 +1,4 @@

1-- | Something.

2−

3data Foo

2data Foo

4 = Foo

3 = Foo

5 Int

4 Int

data/examples/declaration/data/gadt/multiline-out.hs+5−4

@@ -5,10 +5,10 @@ data Foo a where

5 -- | 'Foo' is wonderful.

6 Foo

7 :: forall a b. ( Show a

8− , Eq b

8+ , Eq b -- foo

9− ) -- foo

9+ )

10− -- bar

10+ => -- bar

11− => a

11+ a

12 -> b

13 -> Foo 'Int

14 -- | But 'Bar' is also not too bad.

@@ -20,3 +20,4 @@ data Foo a where

20 Baz

21 :: forall a. a

22 -> Foo 'String

23+ (:~>) :: Foo a -> Foo a -> Foo a

data/examples/declaration/data/gadt/multiline.hs+1

@@ -13,3 +13,4 @@ data Foo a where

13 -- | So is 'Baz'.

14 Baz

15 :: forall a. a -> Foo 'String

16+ (:~>) :: Foo a -> Foo a -> Foo a

data/examples/declaration/data/multiline-arg-parens-out.hsnew file+8

@@ -0,0 +1,8 @@

1+-- | Something.

2+data Foo

3+ = Foo

4+ Bar

5+ (Set Baz) -- and here we go

6+ -- and that's it

7+ Text

8+ deriving (Eq)

data/examples/declaration/data/multiline-arg-parens.hsnew file+8

@@ -0,0 +1,8 @@

1+-- | Something.

2+

3+data Foo

4+ = Foo Bar

5+ (Set Baz) -- and here we go

6+ -- and that's it

7+ Text

8+ deriving (Eq)

data/examples/declaration/data/newline-out.hs → data/examples/declaration/data/newtype-out.hsrenamed

The content is the same.

data/examples/declaration/data/newline.hs → data/examples/declaration/data/newtype.hsrenamed

The content is the same.

data/examples/declaration/data/record-out.hs+8−1

@@ -3,7 +3,14 @@ data Foo

3 = Foo

4 { fooX :: Int -- ^ X

5 , fooY :: Int -- ^ Y

6− , fooBar, fooBaz :: Bool -- ^ BarBaz

6+ , fooBar, fooBaz :: NonEmpty (Identity Bool) -- ^ BarBaz

7+ , fooGag

8+ , fooGog

9+ :: NonEmpty

10+ ( Indentity

11+ Bool

12+ )

13+ -- ^ GagGog

7 , fooFoo

14 , fooFoo

8 , barBar

15 , barBar

9 :: Int -- ^ Huh!

16 :: Int -- ^ Huh!

data/examples/declaration/data/record.hs+4−1

@@ -3,7 +3,10 @@

3data Foo = Foo

4 { fooX :: Int -- ^ X

5 , fooY :: Int -- ^ Y

6− , fooBar, fooBaz :: Bool -- ^ BarBaz

6+ , fooBar, fooBaz :: NonEmpty (Identity Bool) -- ^ BarBaz

7+ , fooGag, fooGog :: NonEmpty (Indentity

8+ Bool)

9+ -- ^ GagGog

7 , fooFoo

10 , fooFoo

8 , barBar :: Int -- ^ Huh!

11 , barBar :: Int -- ^ Huh!

9 } deriving (Eq, Show)

12 } deriving (Eq, Show)

data/examples/declaration/data/simple-broken-out.hsnew file+8

@@ -0,0 +1,8 @@

1+-- | Here we go.

2+data Foo

3+ = Foo {unFoo :: Int}

4+ deriving (Eq)

5+

6+-- | And once again.

7+data Bar = Bar {unBar :: Int}

8+ deriving (Eq)

data/examples/declaration/data/simple-broken.hsnew file+10

@@ -0,0 +1,10 @@

1+-- | Here we go.

2+

3+data Foo

4+ = Foo { unFoo :: Int }

5+ deriving (Eq)

6+

7+-- | And once again.

8+

9+data Bar = Bar { unBar :: Int }

10+ deriving (Eq)

data/examples/import/comments-per-import-out.hs+3−3

@@ -1,4 +1,4 @@

1+-- (1)

1−import Bar

2+import Bar -- (2)

2−import Baz

3+import Baz -- (3)

3import Foo

4import Foo

4−-- (3)

data/examples/import/explicit-imports-with-comments-out.hs+3−2

@@ -1,5 +1,6 @@

1import qualified MegaModule as M

2+ ( -- (1)

2− ( (<<<)

3+ (<<<) -- (2)

3 , (>>>)

4 , (>>>)

4− , Either

5+ , Either -- (3)

5 )

6 )

data/examples/other/multiline-comments-reindent-out.hsnew file+6

@@ -0,0 +1,6 @@

1+{-

2+And so here we have a

3+multiline comment.

4+

5+Indeed.

6+-}

data/examples/other/multiline-comments-reindent.hsnew file+6

@@ -0,0 +1,6 @@

1+ {-

2+ And so here we have a

3+ multiline comment.

4+

5+ Indeed.

6+ -}

ormolu.cabal+5−3

@@ -29,16 +29,17 @@ library

29 hs-source-dirs: src

30 build-depends: base >= 4.8 && < 5.0

31 , containers >= 0.5 && < 0.7

32+ , dlist >= 0.8 && < 0.9

32 , exceptions >= 0.6 && < 0.11

33 , exceptions >= 0.6 && < 0.11

33 , ghc >= 8.4.3

34 , ghc >= 8.4.3

34 , ghc-boot-th >= 8.4.3

35 , ghc-boot-th >= 8.4.3

35− , ghc-exactprint >= 0.5.6

36+ , ghc-paths >= 0.1 && < 0.2

36 , mtl >= 2.0 && < 3.0

37 , mtl >= 2.0 && < 3.0

37 , syb >= 0.7 && < 0.8

38 , syb >= 0.7 && < 0.8

38 , text >= 0.2 && < 1.3

39 , text >= 0.2 && < 1.3

39 , yaml >= 0.8 && < 0.12

40 , yaml >= 0.8 && < 0.12

40 exposed-modules: Ormolu

41 exposed-modules: Ormolu

41− , Ormolu.Comments

42+ , Ormolu.CommentStream

42 , Ormolu.Config

43 , Ormolu.Config

43 , Ormolu.Diff

44 , Ormolu.Diff

44 , Ormolu.Exception

45 , Ormolu.Exception

@@ -56,6 +57,8 @@ library

56 , Ormolu.Printer.Meat.ImportExport

57 , Ormolu.Printer.Meat.ImportExport

57 , Ormolu.Printer.Meat.Module

58 , Ormolu.Printer.Meat.Module

58 , Ormolu.Printer.Meat.Type

59 , Ormolu.Printer.Meat.Type

60+ , Ormolu.SpanStream

61+ , Ormolu.Utils

59 if flag(dev)

62 if flag(dev)

60 ghc-options: -Wall -Werror -Wcompat

63 ghc-options: -Wall -Werror -Wcompat

61 -Wincomplete-record-updates

64 -Wincomplete-record-updates

@@ -94,7 +97,6 @@ executable ormolu

94 hs-source-dirs: app

97 hs-source-dirs: app

95 build-depends: base >= 4.8 && < 5.0

98 build-depends: base >= 4.8 && < 5.0

96 , ghc >= 8.4.3

99 , ghc >= 8.4.3

97− , ghc-exactprint >= 0.5.6

98 , gitrev >= 1.3 && < 1.4

100 , gitrev >= 1.3 && < 1.4

99 , optparse-applicative >= 0.14 && < 0.15

101 , optparse-applicative >= 0.14 && < 0.15

100 , ormolu

102 , ormolu

src/Ormolu.hs+17−8

@@ -18,7 +18,7 @@ import Control.Monad

18import Control.Monad.IO.Class (MonadIO (..))

19import Data.Text (Text)

20import Debug.Trace

21−import Language.Haskell.GHC.ExactPrint.Types

21+import Ormolu.CommentStream

22import Ormolu.Config

23import Ormolu.Diff

24import Ormolu.Exception

@@ -47,20 +47,20 @@ ormolu

47 -> String -- ^ Input to format

48 -> m Text

49ormolu cfg path str = do

50− (ws, (anns0, parsedSrc0)) <-

50+ (ws, (cstream0, parsedSrc0)) <-

51 parseModule' cfg OrmoluParsingFailed path str

52 when (cfgDebug cfg) $ do

53 traceM "warnings:\n"

54 traceM (concatMap showWarn ws)

55− traceM "anns:\n"

55+ traceM "comment stream:\n"

56− traceM (showOutputable anns0)

56+ traceM (showCommentStream cstream0)

57− let txt = printModule (cfgDebug cfg) anns0 parsedSrc0

57+ let txt = printModule (cfgDebug cfg) cstream0 parsedSrc0

58 -- Parse the result of pretty-printing again and make sure that AST is the

59 -- same as AST of original snippet module span positions.

60 unless (cfgUnsafe cfg) $ do

61− (_, (anns1, parsedSrc1)) <-

61+ (_, (cstream1, parsedSrc1)) <-

62 parseModule' cfg OrmoluOutputParsingFailed "<rendered>" (T.unpack txt)

63− when (diff (anns0, parsedSrc0) (anns1, parsedSrc1)) $

63+ when (diff (cstream0, parsedSrc0) (cstream1, parsedSrc1)) $

64 liftIO $ throwIO (OrmoluASTDiffers str txt)

65 return txt

66

@@ -90,7 +90,8 @@ parseModule'

90 -- ^ How to obtain 'OrmoluException' to throw when parsing fails

91 -> FilePath -- ^ File name to use in errors

92 -> String -- ^ Actual input for the parser

93− -> m ([GHC.Warn], (Anns, GHC.ParsedSource)) -- ^ Annotations and parsed source

93+ -> m ([GHC.Warn], (CommentStream, GHC.ParsedSource))

94+ -- ^ Comment stream and parsed source

94parseModule' Config {..} mkException path str = do

95parseModule' Config {..} mkException path str = do

95 (ws, r) <- parseModule cfgDynOptions path str

96 (ws, r) <- parseModule cfgDynOptions path str

96 case r of

97 case r of

@@ -103,6 +104,14 @@ showWarn :: GHC.Warn -> String

103showWarn (GHC.Warn reason l) =

104showWarn (GHC.Warn reason l) =

104 showOutputable reason ++ "\n" ++ showOutputable l ++ "\n"

105 showOutputable reason ++ "\n" ++ showOutputable l ++ "\n"

105

106

107+-- | Pretty-print a 'CommentStream'.

108+

109+showCommentStream :: CommentStream -> String

110+showCommentStream (CommentStream xs) = unlines $

111+ showComment <$> xs

112+ where

113+ showComment (GHC.L l str) = showOutputable l ++ " " ++ show str

114+

106-- | Pretty-print an 'GHC.Outputable' thing.

115-- | Pretty-print an 'GHC.Outputable' thing.

107

116

108showOutputable :: GHC.Outputable o => o -> String

117showOutputable :: GHC.Outputable o => o -> String

src/Ormolu/CommentStream.hsnew file+93

@@ -0,0 +1,93 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3+{-# LANGUAGE LambdaCase #-}

4+

5+-- | Functions for working with comment stream.

6+

7+module Ormolu.CommentStream

8+ ( CommentStream (..)

9+ , Comment (..)

10+ , mkCommentStream

11+ , isPrevHaddock

12+ )

13+where

14+

15+import Data.Data (Data)

16+import Data.List (isPrefixOf, sortOn)

17+import Data.List.NonEmpty (NonEmpty (..))

18+import Data.Maybe (mapMaybe)

19+import SrcLoc

20+import qualified Data.List.NonEmpty as NE

21+import qualified GHC

22+import qualified Lexer as GHC

23+

24+-- | A stream of 'RealLocated' comment strings in ascending order with

25+-- respect to beginning of corresponding spans.

26+

27+newtype CommentStream = CommentStream [RealLocated Comment]

28+ deriving (Eq, Data, Semigroup, Monoid)

29+

30+-- | A wrapper for a single comment.

31+

32+newtype Comment = Comment (NonEmpty String)

33+ deriving (Eq, Show, Data)

34+

35+-- | Create 'CommentStream' from 'GHC.PState'.

36+

37+mkCommentStream

38+ :: [Located String] -- ^ Extra comments to include

39+ -> GHC.PState -- ^ Parser state to use for comment extraction

40+ -> CommentStream

41+mkCommentStream extraComments pstate

42+ = CommentStream

43+ -- NOTE It's easier to normalize pragmas right when we construct comment

44+ -- streams. Because this way we need to do it only once and when we

45+ -- perform checking later they'll automatically match.

46+ . fmap (fmap (Comment . normalizeComment . normalizePragma))

47+ . sortOn startOfSpan

48+ . mapMaybe toRealSpan $

49+ extraComments ++

50+ (fmap unAnnotationComment <$> GHC.comment_q pstate) ++

51+ concatMap (fmap (fmap unAnnotationComment) . snd) (GHC.annotations_comments pstate)

52+ where

53+ startOfSpan (L l _) = realSrcSpanStart l

54+ toRealSpan (L (RealSrcSpan l) a) = Just (L l a)

55+ toRealSpan _ = Nothing

56+

57+-- | Test whether a 'Comment' looks like a Haddock following a definition.

58+

59+isPrevHaddock :: Comment -> Bool

60+isPrevHaddock (Comment (x :| _)) = "-- ^" `isPrefixOf` x

61+

62+----------------------------------------------------------------------------

63+-- Helpers

64+

65+-- | Normalize pragmas by deleting extra white space.

66+

67+normalizePragma :: String -> String

68+normalizePragma x =

69+ if "{-#" `isPrefixOf` x

70+ then unwords (words x)

71+ else x

72+

73+-- | Normalize comment string. Sometimes one multi-line comment is turned

74+-- into several lines for subsequent outputting with correct indentation for

75+-- each line.

76+

77+normalizeComment :: String -> NonEmpty String

78+normalizeComment s =

79+ case NE.nonEmpty (lines s) of

80+ Nothing -> s :| []

81+ Just xs -> dropWhile (== ' ') <$> xs

82+

83+-- | Get a 'String' from 'GHC.AnnotationComment'.

84+

85+unAnnotationComment :: GHC.AnnotationComment -> String

86+unAnnotationComment = \case

87+ GHC.AnnDocCommentNext s -> s

88+ GHC.AnnDocCommentPrev s -> s

89+ GHC.AnnDocCommentNamed s -> s

90+ GHC.AnnDocSection _ s -> s

91+ GHC.AnnDocOptions s -> s

92+ GHC.AnnLineComment s -> s

93+ GHC.AnnBlockComment s -> s

src/Ormolu/Comments.hsdeleted−33

@@ -1,33 +0,0 @@

1−-- | Various functions for manipulation of 'Comment's.

2−

3−module Ormolu.Comments

4− ( annComment

5− , normalizeComment

6− )

7−where

8−

9−import Data.List (isPrefixOf)

10−import Language.Haskell.GHC.ExactPrint.Types

11−

12−-- | If 'KeywordId' is a comment, extract it.

13−

14−annComment :: KeywordId -> Maybe Comment

15−annComment (AnnComment x) = Just x

16−annComment _ = Nothing

17−

18−-- | Normalize comment string. Sometimes one multi-line comment is turned

19−-- into several lines for subsequent outputting with correct indentation for

20−-- each line.

21−

22−normalizeComment :: String -> [String]

23−normalizeComment s =

24− if isMultiline s

25− then if isPragma s

26− then [normalizePragma s]

27− else normalizeIndent s

28− else [s]

29− where

30− isMultiline x = not ("--" `isPrefixOf` x)

31− isPragma x = "{-#" `isPrefixOf` x

32− normalizeIndent = fmap (dropWhile (== ' ')) . lines

33− normalizePragma = unwords . words

src/Ormolu/Config.hs+2−2

@@ -1,9 +1,9 @@

1−-- | Configuration options used by the tool.

2−

3{-# LANGUAGE GeneralizedNewtypeDeriving #-}

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE RecordWildCards #-}

6

4

5+-- | Configuration options used by the tool.

6+

7module Ormolu.Config

8 ( Config (..)

9 , defaultConfig

src/Ormolu/Diff.hs+8−32

@@ -10,26 +10,23 @@ module Ormolu.Diff

10where

11

12import Data.Generics

13−import Data.Maybe (mapMaybe)

13+import GHC

14−import GHC hiding (GhcPs)

15−import Language.Haskell.GHC.ExactPrint.Types

16−import Ormolu.Comments

14+import Ormolu.CommentStream

17import Ormolu.Imports (sortImports)

15import Ormolu.Imports (sortImports)

18−import qualified Data.Map.Strict as M

19

16

20-- | Return 'False' if two annotated ASTs are the same modulo span

17-- | Return 'False' if two annotated ASTs are the same modulo span

21-- positions.

18-- positions.

22

19

23diff

20diff

24− :: (Anns, ParsedSource) -- ^ First annotated AST

21+ :: (CommentStream, ParsedSource) -- ^ First annotated AST

25− -> (Anns, ParsedSource) -- ^ Second annotated AST

22+ -> (CommentStream, ParsedSource) -- ^ Second annotated AST

26 -> Bool

23 -> Bool

27−diff (anns0, ps0) (anns1, ps1) =

24+diff (cstream0, ps0) (cstream1, ps1) =

28− not (matchIgnoringSrcSpans (simplifyAnns anns0) (simplifyAnns anns1))

25+ not (matchIgnoringSrcSpans cstream0 cstream1)

29 || not (matchIgnoringSrcSpans ps0 ps1)

26 || not (matchIgnoringSrcSpans ps0 ps1)

30

27

31−-- | Compare two 'ParsedSource' values disregarding differences in

28+-- | Compare two values for equality disregarding differences in 'SrcSpan's

32−-- 'SrcSpan's and the ordering of import lists.

29+-- and the ordering of import lists.

33

30

34matchIgnoringSrcSpans :: Data a => a -> a -> Bool

31matchIgnoringSrcSpans :: Data a => a -> a -> Bool

35matchIgnoringSrcSpans = genericQuery

32matchIgnoringSrcSpans = genericQuery

@@ -49,24 +46,3 @@ matchIgnoringSrcSpans = genericQuery

49 matchIgnoringSrcSpans

46 matchIgnoringSrcSpans

50 hs0 { hsmodImports = sortImports (hsmodImports hs0) }

47 hs0 { hsmodImports = sortImports (hsmodImports hs0) }

51 hs1 { hsmodImports = sortImports (hsmodImports hs1) }

48 hs1 { hsmodImports = sortImports (hsmodImports hs1) }

52−

53−-- | Simplified collection of 'Comment's.

54−

55−data Comments = Comments [Comment] [Comment] [Comment]

56− deriving (Show, Typeable, Data)

57−

58−-- | Simplify a collection of annotations.

59−

60−simplifyAnns :: Anns -> [Comments]

61−simplifyAnns = fmap simplifyAnn . M.elems

62−

63−-- | Simplify single annotation.

64−

65−simplifyAnn :: Annotation -> Comments

66−simplifyAnn Ann {..} = Comments

67− (f . fst <$> annPriorComments)

68− (f . fst <$> annFollowingComments)

69− (mapMaybe (fmap f . annComment) (fst <$> annsDP))

70− where

71− f (Comment str i o) =

72− Comment (unlines $ normalizeComment str) i o

src/Ormolu/Exception.hs+2−2

@@ -1,7 +1,7 @@

1−-- | 'OrmoluException' type and surrounding definitions.

2−

3{-# LANGUAGE LambdaCase #-}

1{-# LANGUAGE LambdaCase #-}

4

2

3+-- | 'OrmoluException' type and surrounding definitions.

4+

5module Ormolu.Exception

6 ( OrmoluException (..)

7 , withPrettyOrmoluExceptions

src/Ormolu/Imports.hs+2−6

@@ -12,8 +12,9 @@ import Data.Bifunctor

12import Data.Function (on)

13import Data.List (sortBy)

14import GHC hiding (GhcPs, IE)

15+import HsExtension

15import HsImpExp (IE (..))

16import HsImpExp (IE (..))

16−import Language.Haskell.GHC.ExactPrint.Types

17+import Ormolu.Utils (unL)

17

18

18-- | Sort imports by module name. This also sorts explicit import lists for

19-- | Sort imports by module name. This also sorts explicit import lists for

19-- each declaration.

20-- each declaration.

@@ -83,8 +84,3 @@ compareIewn (IEPattern _) (IEType _) = LT

83compareIewn (IEType _) (IEName _) = GT

84compareIewn (IEType _) (IEName _) = GT

84compareIewn (IEType _) (IEPattern _) = GT

85compareIewn (IEType _) (IEPattern _) = GT

85compareIewn (IEType x) (IEType y) = unL x `compare` unL y

86compareIewn (IEType x) (IEType y) = unL x `compare` unL y

86−

87−-- | Exact inner value from 'Located'.

88−

89−unL :: Located e -> e

90−unL (L _ e) = e

src/Ormolu/Parser.hs+102−61

@@ -10,16 +10,23 @@ where

10import Control.Exception

11import Control.Monad

12import Control.Monad.IO.Class

13−import Data.Generics

13+import Data.List (isPrefixOf)

14+import Data.Maybe (catMaybes)

14−import GHC hiding (GhcPs, IE, parseModule)

15+import GHC hiding (IE, parseModule, parser)

15import GHC.LanguageExtensions.Type (Extension (Cpp))

16import GHC.LanguageExtensions.Type (Extension (Cpp))

16−import Language.Haskell.GHC.ExactPrint.Parsers hiding (parseModule)

17+import GHC.Paths (libdir)

17−import Language.Haskell.GHC.ExactPrint.Types

18+import Ormolu.CommentStream

18import Ormolu.Config

19import Ormolu.Config

19import Ormolu.Exception

20import Ormolu.Exception

20import qualified CmdLineParser as GHC

21import qualified CmdLineParser as GHC

21−import qualified Data.Map.Strict as M

22import qualified DynFlags as GHC

23+import qualified FastString as GHC

24+import qualified HeaderInfo as GHC

25+import qualified Lexer as GHC

26+import qualified Outputable as GHC

27+import qualified Parser as GHC

28+import qualified SrcLoc as GHC

29+import qualified StringBuffer as GHC

23

30

24-- | Parse a complete module from string.

31-- | Parse a complete module from string.

25

32

@@ -28,8 +35,9 @@ parseModule

28 => [DynOption] -- ^ Dynamic options that affect parsing

35 => [DynOption] -- ^ Dynamic options that affect parsing

29 -> FilePath -- ^ File name (only for source location annotations)

36 -> FilePath -- ^ File name (only for source location annotations)

30 -> String -- ^ Input for parser

37 -> String -- ^ Input for parser

31− -> m ([GHC.Warn], Either (SrcSpan, String) (Anns, ParsedSource))

38+ -> m ([GHC.Warn], Either (SrcSpan, String) (CommentStream, ParsedSource))

32−parseModule dynOpts path input = liftIO $ do

39+parseModule dynOpts path input' = liftIO $ do

40+ let (input, extraComments) = stripLinePragmas input'

33 (ws, dynFlags) <- ghcWrapper $ do

41 (ws, dynFlags) <- ghcWrapper $ do

34 dynFlags0 <- initDynFlagsPure path input

42 dynFlags0 <- initDynFlagsPure path input

35 (dynFlags1, _, ws) <-

43 (dynFlags1, _, ws) <-

@@ -40,64 +48,97 @@ parseModule dynOpts path input = liftIO $ do

40 -- want.

48 -- want.

41 when (GHC.xopt Cpp dynFlags) $

49 when (GHC.xopt Cpp dynFlags) $

42 throwIO OrmoluCppEnabled

50 throwIO OrmoluCppEnabled

43− let r = case parseModuleFromStringInternal dynFlags path input of

51+ let r = case runParser GHC.parseModule dynFlags path input of

44− Left e -> Left e

52+ GHC.PFailed _ ss m -> Left (ss, GHC.showSDoc dynFlags m)

45− Right (anns, psrc) ->

53+ GHC.POk x pmod -> Right (mkCommentStream extraComments x, pmod)

46− Right (dropImportComments anns psrc, psrc)

47 return (ws, r)

54 return (ws, r)

48

55

49−-- | Drop comments associated with elements of import lists. The reason we

56+----------------------------------------------------------------------------

50−-- do this is that those comments are not associated as user would expect.

57+-- Helpers (taken from ghc-exactprint)

51−--

58+

52−-- For example:

59+-- | Requires GhcMonad constraint because there is no pure variant of

53−--

60+-- 'parseDynamicFilePragma'. Yet, in constrast to 'initDynFlags', it does

54−-- > import Foo -- (1)

61+-- not (try to) read the file at filepath, but solely depends on the module

55−-- > import Bar -- (2)

62+-- source in the input string.

56−-- > import Baz -- (3)

57−--

58−-- Here, @(1)@ is considered preceding comment of @Baz@ import, in fact, it

59−-- has nothing to do with @Foo@. Similarly, @(2)@ is associted with @Baz@,

60−-- not @Bar@. Finally @(3)@ is actually preceeding comment for the thing

61−-- that follows the import list, or if nothing follows, it's a trailing

62−-- comment of the whole module.

63−--

64−-- Since we do sorting of imports when we print them, we would need to do

65−-- sorting of corresponding annotations as well (because we do checking of

66−-- annotations and AST in "Ormolu.Diff" as part of the self-check), and this

67−-- is hard. Even if we manage to do that the result will be totally

68−-- confusing, e.g. for the example above:

69−--

70−-- > -- (1)

71−-- > import Bar

72−-- > -- (2)

73−-- > import Baz

74−-- > import Foo

75−-- > -- (3)

76−--

77−-- The solution is to drop the tricky comments right after parsing, so we

78−-- don't need to deal with them at all, including the need to update

79−-- annotations for the correctness checking we do in "Ormolu.Diff".

80--

63--

81−-- The solution is not perfect, but practical.

64+-- Passes "-hide-all-packages" to the GHC API to prevent parsing of package

65+-- environment files. However this only works if there is no invocation of

66+-- 'setSessionDynFlags' before calling 'initDynFlagsPure'. See GHC tickets

67+-- #15513, #15541.

68+

69+initDynFlagsPure

70+ :: GHC.GhcMonad m

71+ => FilePath -- ^ Module path

72+ -> String -- ^ Module contents

73+ -> m GHC.DynFlags -- ^ Dynamic flags for that module

74+initDynFlagsPure fp input = do

75+ -- I was told we could get away with using the 'unsafeGlobalDynFlags'. as

76+ -- long as 'parseDynamicFilePragma' is impure there seems to be no reason

77+ -- to use it.

78+ dflags0 <- GHC.getSessionDynFlags

79+ let pragmaInfo = GHC.getOptions dflags0 (GHC.stringToStringBuffer input) fp

80+ (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 pragmaInfo

81+ -- Turn this on last to avoid T10942

82+ let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream

83+ -- Prevent parsing of .ghc.environment.* "package environment files"

84+ (dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine

85+ dflags2

86+ [GHC.noLoc "-hide-all-packages"]

87+ _ <- GHC.setSessionDynFlags dflags3

88+ return dflags3

82

89

83−dropImportComments

90+-- | Default runner of 'GHC.Ghc' action in 'IO'.

84− :: Anns

85− -> ParsedSource

86− -> Anns

87−dropImportComments anns (L _ HsModule {..}) =

88− foldr M.delete anns (hsmodImports >>= keyAnnsFor)

89

91

90−-- | Extract all 'AnnKey's from given 'Data'.

92+ghcWrapper :: GHC.Ghc a -> IO a

93+ghcWrapper

94+ = GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut

95+ . GHC.runGhc (Just libdir)

91

96

92−keyAnnsFor :: GenericQ [AnnKey]

97+-- | Run a 'GHC.P' computation.

93−keyAnnsFor a = everything mappend (const id `ext2Q` queryLocated) a []

98+

99+runParser

100+ :: GHC.P a -- ^ Computation to run

101+ -> GHC.DynFlags -- ^ Dynamic flags

102+ -> FilePath -- ^ Module path

103+ -> String -- ^ Module contents

104+ -> GHC.ParseResult a -- ^ Parse result

105+runParser parser flags filename input = GHC.unP parser parseState

106+ where

107+ location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1

108+ buffer = GHC.stringToStringBuffer input

109+ parseState = GHC.mkPState flags buffer location

110+

111+-- | Remove GHC style line pragams (@{-# LINE .. #-}@) and convert them into

112+-- comments.

113+

114+stripLinePragmas :: String -> (String, [Located String])

115+stripLinePragmas = unlines' . unzip . findLines . lines

94 where

116 where

95− queryLocated

117+ unlines' (a, b) = (unlines a, catMaybes b)

96− :: (Data e0, Data e1)

118+

97− => GenLocated e0 e1

119+findLines :: [String] -> [(String, Maybe (Located String))]

98− -> [AnnKey]

120+findLines = zipWith checkLine [1..]

99− -> [AnnKey]

121+

100− queryLocated (L mspn x) =

122+checkLine :: Int -> String -> (String, Maybe (Located String))

101− case cast mspn :: Maybe SrcSpan of

123+checkLine line s

124+ | "{-# LINE" `isPrefixOf` s =

125+ let (pragma, res) = getPragma s

126+ size = length pragma

127+ mSrcLoc = mkSrcLoc (GHC.mkFastString "LINE")

128+ ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (size+1))

129+ in (res, Just $ L ss pragma)

130+ -- Deal with shebang/cpp directives too

131+ -- x | "#" `isPrefixOf` s = ("",Just $ Comment ((line, 1), (line, length s)) s)

132+ | "#!" `isPrefixOf` s =

133+ let mSrcLoc = mkSrcLoc (GHC.mkFastString "SHEBANG")

134+ ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (length s))

135+ in ("",Just $ L ss s)

102− Nothing -> id

136+ | otherwise = (s, Nothing)

103− Just spn -> (mkAnnKey (L spn x) :)

137+

138+getPragma :: String -> (String, String)

139+getPragma [] = error "Ormolu.Parser.getPragma: input must not be empty"

140+getPragma s@(x:xs)

141+ | "#-}" `isPrefixOf` s = ("#-}", " " ++ drop 3 s)

142+ | otherwise =

143+ let (prag, remline) = getPragma xs

144+ in (x:prag, ' ':remline)

src/Ormolu/Printer.hs+7−6

@@ -10,17 +10,18 @@ module Ormolu.Printer

10where

11

12import Data.Text (Text)

13−import GHC (ParsedSource)

13+import GHC

14−import Language.Haskell.GHC.ExactPrint.Types

14+import Ormolu.CommentStream

15import Ormolu.Printer.Combinators

16import Ormolu.Printer.Meat.Module

17+import Ormolu.SpanStream

17

18

18-- | Render a module.

19-- | Render a module.

19

20

20printModule

21printModule

21− :: Bool -- ^ Trace debugging information

22+ :: Bool -- ^ Whether to trace debugging information

22− -> Anns -- ^ Annotations

23+ -> CommentStream -- ^ Comment stream

23 -> ParsedSource -- ^ Parsed source

24 -> ParsedSource -- ^ Parsed source

24 -> Text -- ^ Resulting rendition

25 -> Text -- ^ Resulting rendition

25−printModule debugOn anns src =

26+printModule debugOn cstream src =

26− runR debugOn (p_hsModule src) anns

27+ runR debugOn (p_hsModule src) (mkSpanStream src) cstream

src/Ormolu/Printer/Combinators.hs+20−37

@@ -15,6 +15,7 @@ module Ormolu.Printer.Combinators

15 , newline

16 , inci

17 , relaxComments

18+ , hasMoreComments

18 , located

19 , located

19 , locatedVia

20 , locatedVia

20 , located'

21 , located'

@@ -44,9 +45,9 @@ import Data.Bool (bool)

44import Data.Data (Data)

45import Data.Data (Data)

45import Data.List (intersperse)

46import Data.List (intersperse)

46import Data.Text (Text)

47import Data.Text (Text)

47−import Language.Haskell.GHC.ExactPrint.Types

48import Ormolu.Printer.Comments

49import Ormolu.Printer.Internal

50+import Ormolu.Utils (unL, getSpan, isModule)

50import Outputable (Outputable (..), showSDocUnsafe)

51import Outputable (Outputable (..), showSDocUnsafe)

51import SrcLoc

52import SrcLoc

52import qualified Data.Text as T

53import qualified Data.Text as T

@@ -85,43 +86,25 @@ locatedVia

85 -> Located a -- ^ Thing to enter

86 -> Located a -- ^ Thing to enter

86 -> (a -> R ()) -- ^ How to render inner value

87 -> (a -> R ()) -- ^ How to render inner value

87 -> R ()

88 -> R ()

88−locatedVia ml loc@(L l a) f = do

89+locatedVia ml loc f = do

89− mann <- lookupAnn loc

90 relaxed <- relaxedComments

91− let m = case ml of

92− Nothing -> f a

93− Just l' -> switchLayout l' (f a)

94− case mann of

95− Nothing -> m

96− Just Ann {..} -> bool sitcc id relaxed $ do

91+ bool sitcc id relaxed $ do

97− -- There are three things in 'Ann' which contain comments:

92+ let withRealLocated (L l a) g =

98−

93+ case l of

99− let cmode =

94+ UnhelpfulSpan _ -> return ()

100− if annGetConstr a == CN "HsModule"

95+ RealSrcSpan l' -> g (L l' a)

96+ withRealLocated loc spitPrecedingComments

97+ let setEnclosingSpan =

98+ case getSpan loc of

99+ UnhelpfulSpan _ -> id

100+ RealSrcSpan orf ->

101+ if isModule (unL loc)

101− then Module

102+ then id

102− else Other

103+ else withEnclosingSpan orf

103− (before, after) = partitionDPs cmode l annsDP

104+ setEnclosingSpan $ case ml of

104−

105+ Nothing -> f (unL loc)

105− -- 'annPriorComments' contains comments that were directly placed

106+ Just l' -> switchLayout l' (f (unL loc))

106− -- before entities such as comments (in both styles) before function

107+ withRealLocated loc spitFollowingComments

107− -- definitions and inline comments before smaller things like types

108− -- and literals.

109−

110− spitComments (addDecoration cmode Before l <$> annPriorComments)

111−

112− -- Comments inside 'annsDP' marked with 'AnnComment' are trickier,

113− -- they seem to contain everything that goes after the thing they

114− -- are attached to and in some cases (e.g. for modules) they contain

115− -- comments that go before things. Exact location can only be

116− -- deduced by analyzing the associated span.

117−

118− spitComments before

119− m

120− spitComments after

121−

122− -- I wasn't able to find any case when 'annFollowingComments' is

123− -- populated, so we'll ignore that one for now and fix it when we

124− -- have an example of source code where it matters.

125

108

126-- | A version of 'located' with arguments flipped.

109-- | A version of 'located' with arguments flipped.

127

110

src/Ormolu/Printer/Comments.hs+189−170

@@ -1,186 +1,205 @@

1−-- | Helpers for formatting of comments.

2−

3{-# LANGUAGE LambdaCase #-}

1{-# LANGUAGE LambdaCase #-}

4{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

5

3

4+-- | Helpers for formatting of comments.

5+

6module Ormolu.Printer.Comments

7− ( -- * Types

7+ ( spitPrecedingComments

8− Decoration (..)

8+ , spitFollowingComments

9− , Decorator (..)

9+ , spitRemainingComments

10− , Position (..)

11− , CommentMode (..)

12− -- * Functions for working with comments

13− , spitComments

14− , partitionDPs

15− , addDecoration

16 )

10 )

17where

11where

18

12

19−import ApiAnnotation (AnnKeywordId (AnnModule))

20import Control.Monad

13import Control.Monad

21−import Data.Bifunctor

14+import Data.Coerce (coerce)

15+import Data.Data (Data)

22−import Data.Maybe (mapMaybe)

16+import Data.Maybe (isJust)

23−import Language.Haskell.GHC.ExactPrint.Types

24−import Ormolu.Comments

17+import Ormolu.CommentStream

25import Ormolu.Printer.Internal

18import Ormolu.Printer.Internal

19+import Ormolu.Utils (isModule, getSpan)

26import SrcLoc

20import SrcLoc

21+import qualified Data.List.NonEmpty as NE

27import qualified Data.Text as T

22import qualified Data.Text as T

28

23

29−-- | Placement instructions for comments.

24+----------------------------------------------------------------------------

30−

25+-- Top-level

31−data Decoration

26+

32− = Decoration Decorator Decorator

27+-- | Output all preceding comments for an element at given location.

33− deriving (Eq, Show)

28+

34−

29+spitPrecedingComments

35−-- | Decorator in this context is a thing to put before\/after a comment.

30+ :: Data a

36−

31+ => RealLocated a -- ^ AST element to attach comments to

37−data Decorator

32+ -> R ()

38− = NoDec -- ^ Output nothing

33+spitPrecedingComments = handleCommentSeries . spitPrecedingComment

39− | SpaceDec -- ^ Output single space

34+

40− | NewlineDec -- ^ Output single newline

35+-- | Output all comments following an element at given location.

41− deriving (Eq, Show)

36+

42−

37+spitFollowingComments

43−-- | Position: before vs after.

38+ :: Data a

44−

39+ => RealLocated a -- ^ AST element of attach comments to

45−data Position

40+ -> R ()

46− = Before -- ^ Before

41+spitFollowingComments ref = do

47− | After -- ^ After

42+ trimSpanStream (getSpan ref)

48− deriving (Eq, Show)

43+ handleCommentSeries (spitFollowingComment ref)

49−

44+

50−-- | For which type of AST leaf we're preparing the comments.

45+-- | Output all remaining comments in the comment stream.

51−

46+

52−data CommentMode

47+spitRemainingComments :: R ()

53− = Module -- ^ Module

48+spitRemainingComments = handleCommentSeries spitRemainingComment

54− | Other -- ^ Other element

49+

55− deriving (Eq, Show)

50+----------------------------------------------------------------------------

56−

51+-- Single-comment functions

57−-- | Output a bunch of 'Comment's. 'DeltaPos'es are used to insert extra

52+

58−-- space between the comments when necessary.

53+-- | Output a single preceding comment for an element at given location.

59−

54+

60−spitComments :: [(Comment, Decoration)] -> R ()

55+spitPrecedingComment

61−spitComments = mapM_ $ \(comment, (Decoration d0 d1)) -> do

56+ :: Data a

62− let spitDecorator = \case

57+ => RealLocated a -- ^ AST element to attach comments to

63− NoDec -> return ()

58+ -> Maybe RealSrcSpan -- ^ Location of last comment in the series

64− SpaceDec -> spit " "

59+ -> R (Maybe RealSrcSpan) -- ^ Location of this comment

65− NewlineDec -> newline

60+spitPrecedingComment (L ref a) mlastSpn = do

66− spitDecorator d0

61+ let p (L l _) = realSrcSpanEnd l <= realSrcSpanStart ref

67− spitComment comment

62+ withPoppedComment p $ \l comment -> do

68− spitDecorator d1

63+ when (needsNewlineBefore l mlastSpn) newline

69−

64+ spitComment comment

70−-- | Output a 'Comment'.

65+ if theSameLine l ref && not (isModule a)

71−

66+ then spit " "

72−spitComment :: Comment -> R ()

67+ else newline

73−spitComment (Comment str _ _) =

68+

74− forM_ (normalizeComment str) $ \x -> do

69+-- | Output a comment that follows element at given location immediately on

75− ensureIndent

70+-- the same line, if there is any.

76− spit (T.pack x)

71+

77−

72+spitFollowingComment

78−-- | Partition annotations to get a collection of 'Comment's preceding a

73+ :: Data a

79−-- definition and following it. Every 'Comment' has corresponding

74+ => RealLocated a -- ^ AST element to attach comments to

80−-- 'Decoration' which is used to understand how to decorate it.

75+ -> Maybe RealSrcSpan -- ^ Location of last comment in the series

81−

76+ -> R (Maybe RealSrcSpan) -- ^ Location of this comment

82−partitionDPs

77+spitFollowingComment (L ref a) mlastSpn = do

83− :: CommentMode -- ^ For which type of element we prepare comments

78+ mnSpn <- nextEltSpan

84− -> SrcSpan -- ^ Span of element the comments are attached to

79+ meSpn <- getEnclosingSpan

85− -> [(KeywordId, DeltaPos)] -- ^ Annotations

80+ i <- getIndent

86− -> ([(Comment, Decoration)], [(Comment, Decoration)])

81+ withPoppedComment (commentFollowsElt ref mnSpn meSpn mlastSpn) $ \l comment ->

87−partitionDPs cmode refSpan anns =

82+ if theSameLine l ref && not (isModule a)

88− case cmode of

83+ then modNextline $ \m -> setIndent i $ do

89− Module -> partitionDPsModule refSpan anns

84+ spit " "

90− Other -> partitionDPsOther refSpan anns

85+ spitComment comment

91−

86+ m

92−-- | Try to partition comments as if for a module.

87+ else modNextline $ \m -> setIndent i $ do

93−

88+ m

94−partitionDPsModule

89+ when (needsNewlineBefore l mlastSpn) newline

95− :: SrcSpan -- ^ Span of element the comments are attached to

90+ spitComment comment

96− -> [(KeywordId, DeltaPos)] -- ^ Annotations

91+ newline

97− -> ([(Comment, Decoration)], [(Comment, Decoration)])

92+

98−partitionDPsModule refSpan xs

93+-- | Output a single remaining comment from the comment stream.

99− = bimap (takeComments Before) (takeComments After) $

94+

100− -- NOTE If there is no annotation corresponding to module keyword, then

95+spitRemainingComment

101− -- the module doesn't have a header and all comments shoud go after.

96+ :: Maybe RealSrcSpan -- ^ Location of last comment in the series

102− if G AnnModule `elem` fmap fst xs

97+ -> R (Maybe RealSrcSpan) -- ^ Location of this comment

103− then break ((== G AnnModule) . fst) xs

98+spitRemainingComment mlastSpn =

104− else ([], xs)

99+ withPoppedComment (const True) $ \l comment -> do

100+ when (needsNewlineBefore l mlastSpn) newline

101+ spitComment comment

102+ newline

103+

104+----------------------------------------------------------------------------

105+-- Helpers

106+

107+-- | Output series of comments.

108+

109+handleCommentSeries

110+ :: (Maybe RealSrcSpan -> R (Maybe RealSrcSpan))

111+ -- ^ Given location of previous comment, output the next comment

112+ -- returning its location, or 'Nothing' if we are done

113+ -> R ()

114+handleCommentSeries f = go Nothing

105 where

115 where

106− takeComments pos = mapMaybe $ \(keywordId, dpos) -> do

116+ go mlastSpn = do

107− c <- annComment keywordId

117+ r <- f mlastSpn

108− return (c, getDecoration Module pos refSpan (c, dpos))

118+ case r of

109−

119+ Nothing -> return ()

110−-- | Partition comments according to their spans (works for everything but

120+ Just spn -> go (Just spn)

111−-- modules).

121+

112−

122+-- | Try to pop a comment using given predicate and if there is a comment

113−partitionDPsOther

123+-- matching the predicate, print it out.

114− :: SrcSpan -- ^ Span of element the comments are attached to

124+

115− -> [(KeywordId, DeltaPos)] -- ^ Annotations

125+withPoppedComment

116− -> ([(Comment, Decoration)], [(Comment, Decoration)])

126+ :: (RealLocated Comment -> Bool) -- ^ Comment predicate

117−partitionDPsOther refSpan

127+ -> (RealSrcSpan -> Comment -> R ()) -- ^ Priting function

118− = bimap (fmap (addDecoration Other Before refSpan))

128+ -> R (Maybe RealSrcSpan)

119− (fixupLastDec . fmap (addDecoration Other After refSpan))

129+withPoppedComment p f = do

120− . break (followedBySpan refSpan . commentIdentifier . fst)

130+ r <- popComment p

121− . mapMaybe annComment'

131+ case r of

132+ Nothing -> return Nothing

133+ Just (L l comment) -> Just l <$ f l comment

134+

135+-- | Determine if we need to insert a newline between current comment and

136+-- last printed comment.

137+

138+needsNewlineBefore

139+ :: RealSrcSpan -- ^ Current comment span

140+ -> Maybe RealSrcSpan -- ^ Last printed comment span

141+ -> Bool

142+needsNewlineBefore l mlastSpn =

143+ case mlastSpn of

144+ Nothing -> False

145+ Just lastSpn ->

146+ srcSpanStartLine l > srcSpanEndLine lastSpn + 1

147+

148+-- | Is the comment and AST element are on the same line?

149+

150+theSameLine

151+ :: RealSrcSpan -- ^ Current comment span

152+ -> RealSrcSpan -- ^ AST element location

153+ -> Bool

154+theSameLine l ref =

155+ srcSpanEndLine l == srcSpanStartLine ref

156+

157+-- | Determine if given comment follows AST element.

158+

159+commentFollowsElt

160+ :: RealSrcSpan -- ^ Location of AST element

161+ -> Maybe RealSrcSpan -- ^ Location of next AST element

162+ -> Maybe RealSrcSpan -- ^ Location of enclosing AST element

163+ -> Maybe RealSrcSpan -- ^ Location of last comment in the series

164+ -> RealLocated Comment -- ^ Comment to test

165+ -> Bool

166+commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =

167+ -- A comment follows a AST element if all 4 conditions are satisfied:

168+ goesAfter && logicallyFollows && noEltBetween && supersedesParentElt

122 where

169 where

123− annComment' :: (KeywordId, DeltaPos) -> Maybe (Comment, DeltaPos)

170+ -- 1) The comment starts after end of the AST element:

124− annComment' (keywordId, dpos) = do

171+ goesAfter =

125− c <- annComment keywordId

172+ realSrcSpanStart l >= realSrcSpanEnd ref

126− return (c, dpos)

173+ -- 2) The comment logically belongs to the element, three cases:

127− followedBySpan :: SrcSpan -> SrcSpan -> Bool

174+ logicallyFollows

128− followedBySpan spn0 spn1 =

175+ = theSameLine l ref -- a) it's on the same line

129− if srcSpanEnd spn0 < srcSpanStart spn1

176+ || isPrevHaddock comment -- b) it's a Haddock string starting with -- ^

130− then True

177+ || isJust mlastSpn -- c) it's a continuation of a comment block

131− else False

178+ -- 3) There is no other AST element between this element and the comment:

132−

179+ noEltBetween =

133−-- | Last following comment cannot be standalone because in that case we get

180+ case mnSpn of

134−-- redundant newlines.

181+ Nothing -> True

135−

182+ Just nspn ->

136−fixupLastDec :: [(Comment, Decoration)] -> [(Comment, Decoration)]

183+ realSrcSpanStart nspn >= realSrcSpanEnd l

137−fixupLastDec [] = []

184+ -- Less obvious: if column of comment is closer to the start of

138−fixupLastDec [(c, Decoration d0 _)] = [(c, Decoration d0 NoDec)]

185+ -- enclosing element, it probably related to that parent element, not to

139−fixupLastDec (c:cs) = c : fixupLastDec cs

186+ -- the current child element. This rule is important because otherwise

140−

187+ -- all comments would end up assigned to closest inner elements, and

141−-- | Replace 'DeltaPos' with 'Decoration'.

188+ -- parent elements won't have a chance to get any comments assigned to

142−

189+ -- them. This is not OK because comments will get indented according to

143−addDecoration

190+ -- the AST elements they are attached to.

144− :: CommentMode -- ^ For which type of element we prepare comments

191+ supersedesParentElt =

145− -> Position -- ^ Is this for comments before or after?

192+ case meSpn of

146− -> SrcSpan -- ^ Span of element the comments are attached to

193+ Nothing -> True

147− -> (Comment, DeltaPos) -- ^ Thing to decorate

194+ Just espn ->

148− -> (Comment, Decoration)

195+ let startColumn = srcLocCol . realSrcSpanStart

149−addDecoration cmode pos refSpan (comment, dpos) =

196+ in abs (startColumn espn - startColumn l)

150− ( comment

197+ > abs (startColumn ref - startColumn l)

151− , getDecoration cmode pos refSpan (comment, dpos)

198+

152− )

199+-- | Output a 'Comment'. This is a low-level printing function.

153

200

154−-- | Calculate decoration for a comment.

201+spitComment :: Comment -> R ()

155−

202+spitComment =

156−getDecoration

203+ sequence_ . NE.intersperse newline . fmap f . coerce

157− :: CommentMode -- ^ For which type of element we prepare comments

158− -> Position -- ^ Is this for comment before or after?

159− -> SrcSpan -- ^ Span of element the comments are attached to

160− -> (Comment, DeltaPos) -- ^ Thing to decorate

161− -> Decoration

162−getDecoration cmode pos refSpan (c, (DP (r, _))) =

163− Decoration preceedingDec followingDec

164 where

204 where

165− preceedingDec =

205+ f x = ensureIndent >> spit (T.pack x)

166− if sameLine

167− then case pos of

168− Before -> NoDec

169− After -> SpaceDec

170− else if r > 1

171− then NewlineDec

172− else NoDec

173− followingDec =

174− if sameLine

175− then case pos of

176− Before -> SpaceDec

177− After -> NewlineDec

178− else NewlineDec

179− sameLine =

180− case cmode of

181− Module -> False

182− Other ->

183− case (refSpan, commentIdentifier c) of

184− (RealSrcSpan spn0, RealSrcSpan spn1) ->

185− srcSpanEndLine spn0 == srcSpanStartLine spn1

186− (_, _) -> False

src/Ormolu/Printer/Internal.hs+150−40

@@ -1,5 +1,6 @@

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE RankNTypes #-}

3

4

4-- | In most cases import "Ormolu.Printer.Combinators" instead, these

5-- | In most cases import "Ormolu.Printer.Combinators" instead, these

5-- functions are the low-level building blocks and should not be used on

6-- functions are the low-level building blocks and should not be used on

@@ -13,6 +14,7 @@ module Ormolu.Printer.Internal

13 -- * Internal functions

14 -- * Internal functions

14 , spit

15 , spit

15 , newline

16 , newline

17+ , modNextline

16 , ensureIndent

18 , ensureIndent

17 , inci

19 , inci

18 , sitcc

20 , sitcc

@@ -21,21 +23,31 @@ module Ormolu.Printer.Internal

21 , enterLayout

23 , enterLayout

22 , vlayout

24 , vlayout

23 , relaxedComments

25 , relaxedComments

24− , lookupAnn

26+ -- * Special helpers for comment placement

27+ , trimSpanStream

28+ , nextEltSpan

29+ , popComment

30+ , hasMoreComments

31+ , getIndent

32+ , setIndent

33+ , getEnclosingSpan

34+ , withEnclosingSpan

25 )

35 )

26where

36where

27

37

28import Control.Monad.Reader

38import Control.Monad.Reader

29import Control.Monad.State.Strict

39import Control.Monad.State.Strict

30−import Data.Data (Data)

40+import Data.Coerce

41+import Data.Maybe (listToMaybe)

31import Data.Text (Text)

42import Data.Text (Text)

32import Data.Text.Lazy.Builder

43import Data.Text.Lazy.Builder

33import Debug.Trace

44import Debug.Trace

34−import Language.Haskell.GHC.ExactPrint.Types

45+import GHC

46+import Ormolu.CommentStream

47+import Ormolu.SpanStream

35import SrcLoc

48import SrcLoc

36−import qualified Data.Text.Lazy as TL

37−import qualified Data.Map as M

38import qualified Data.Text as T

49import qualified Data.Text as T

50+import qualified Data.Text.Lazy as TL

39

51

40----------------------------------------------------------------------------

52----------------------------------------------------------------------------

41-- The 'R' monad

53-- The 'R' monad

@@ -56,10 +68,10 @@ data RC = RC

56 -- ^ Current layout

68 -- ^ Current layout

57 , rcRelaxedComments :: Bool

69 , rcRelaxedComments :: Bool

58 -- ^ Whether to relax aligning rules for comments

70 -- ^ Whether to relax aligning rules for comments

59− , rcAnns :: Anns

60− -- ^ The collection of annotations obtained after parsing

61 , rcDebug :: Bool

71 , rcDebug :: Bool

62 -- ^ Whether to print debugging info as we go

72 -- ^ Whether to print debugging info as we go

73+ , rcEnclosingSpan :: Maybe RealSrcSpan

74+ -- ^ Span of enclosing element of AST

63 }

75 }

64

76

65-- | State context of 'R'.

77-- | State context of 'R'.

@@ -69,6 +81,12 @@ data SC = SC

69 -- ^ Index of the next column to render

81 -- ^ Index of the next column to render

70 , scBuilder :: Builder

82 , scBuilder :: Builder

71 -- ^ Rendered source code so far

83 -- ^ Rendered source code so far

84+ , scSpanStream :: SpanStream

85+ -- ^ Span stream

86+ , scCommentStream :: CommentStream

87+ -- ^ Comment stream

88+ , scNewline :: R ()

89+ -- ^ What to render as newline

72 }

90 }

73

91

74-- | 'Layout' options.

92-- | 'Layout' options.

@@ -83,21 +101,25 @@ data Layout

83runR

101runR

84 :: Bool -- ^ Whether to print debugging info

102 :: Bool -- ^ Whether to print debugging info

85 -> R () -- ^ Monad to run

103 -> R () -- ^ Monad to run

86− -> Anns -- ^ Annotations to use

104+ -> SpanStream -- ^ Span stream

105+ -> CommentStream -- ^ Comment stream

87 -> Text -- ^ Resulting rendition

106 -> Text -- ^ Resulting rendition

88−runR debug (R m) anns =

107+runR debug (R m) sstream cstream =

89 TL.toStrict . toLazyText . scBuilder $ execState (runReaderT m rc) sc

108 TL.toStrict . toLazyText . scBuilder $ execState (runReaderT m rc) sc

90 where

109 where

91 rc = RC

110 rc = RC

92 { rcIndent = 0

111 { rcIndent = 0

93 , rcLayout = MultiLine

112 , rcLayout = MultiLine

94 , rcRelaxedComments = False

113 , rcRelaxedComments = False

95− , rcAnns = anns

96 , rcDebug = debug

114 , rcDebug = debug

115+ , rcEnclosingSpan = Nothing

97 }

116 }

98 sc = SC

117 sc = SC

99 { scColumn = 0

118 { scColumn = 0

100 , scBuilder = mempty

119 , scBuilder = mempty

120+ , scSpanStream = sstream

121+ , scCommentStream = cstream

122+ , scNewline = newlineRaw

101 }

123 }

102

124

103----------------------------------------------------------------------------

125----------------------------------------------------------------------------

@@ -109,26 +131,49 @@ runR debug (R m) anns =

109spit :: Text -> R ()

131spit :: Text -> R ()

110spit x = do

132spit x = do

111 traceR "spit_before" (Just x)

133 traceR "spit_before" (Just x)

112− R (modify modSC)

134+ R . modify $ \sc -> sc

135+ { scBuilder = scBuilder sc <> fromText x

136+ , scColumn = scColumn sc + T.length x

137+ }

113 traceR "spit_after" Nothing

138 traceR "spit_after" Nothing

114− where

115− modSC sc = sc

116− { scBuilder = scBuilder sc <> fromText x

117− , scColumn = scColumn sc + T.length x

118− }

119

139

120−-- | Output a newline.

140+-- | Output a newline. The 'modNewline' function can be used to alter what

141+-- will be inserted. This is used to output comments following an element of

142+-- AST because we cannot output comments immediately, e.g. because we need

143+-- to close parentheses first, etc.

144+--

145+-- 'newline' auto-resets its modifications so the changes introduced with

146+-- 'modNewline' only have effect once.

121

147

122newline :: R ()

148newline :: R ()

123newline = do

149newline = do

150+ n <- R (gets scNewline)

151+ R . modify $ \sc -> sc

152+ { scNewline = newlineRaw

153+ }

154+ n

155+

156+-- | Low-level newline primitive. This one always just inserts a newline, no

157+-- hooks can be attached.

158+

159+newlineRaw :: R ()

160+newlineRaw = do

124 traceR "newline_before" (Just "\n")

161 traceR "newline_before" (Just "\n")

125− R (modify modSC)

162+ R . modify $ \sc -> sc

163+ { scBuilder = scBuilder sc <> "\n"

164+ , scColumn = 0

165+ }

126 traceR "newline_after" Nothing

166 traceR "newline_after" Nothing

127− where

167+

128− modSC sc = sc

168+-- | Modify how next newline will be output. The argument of call-back is

129− { scBuilder = scBuilder sc <> "\n"

169+-- the version of 'newline' built so far.

130− , scColumn = 0

170+

171+modNextline :: (R () -> R ()) -> R ()

172+modNextline f = R $ do

173+ old <- gets scNewline

174+ modify $ \sc -> sc

175+ { scNewline = f old

131− }

176+ }

132

177

133-- | Ensure that indentation level is satisfied. Insert correct number of

178-- | Ensure that indentation level is satisfied. Insert correct number of

134-- spaces if it isn't.

179-- spaces if it isn't.

@@ -148,12 +193,11 @@ inci :: R () -> R ()

148inci m' = do

193inci m' = do

149 traceR "inci_before" Nothing

194 traceR "inci_before" Nothing

150 let R m = traceR "inci_inside" Nothing >> m'

195 let R m = traceR "inci_inside" Nothing >> m'

196+ modRC rc = rc

197+ { rcIndent = rcIndent rc + indentStep

198+ }

151 R (local modRC m)

199 R (local modRC m)

152 traceR "inci_ended" Nothing

200 traceR "inci_ended" Nothing

153− where

154− modRC x = x

155− { rcIndent = rcIndent x + indentStep

156− }

157

201

158-- | Set indentation level for the inner computation equal to current

202-- | Set indentation level for the inner computation equal to current

159-- column. This makes sure that the entire inner block is uniformly

203-- column. This makes sure that the entire inner block is uniformly

@@ -165,10 +209,10 @@ sitcc m' = do

165 traceR "sitcc_before" Nothing

209 traceR "sitcc_before" Nothing

166 i <- R (asks rcIndent)

210 i <- R (asks rcIndent)

167 c <- R (gets scColumn)

211 c <- R (gets scColumn)

212+ let R m = traceR "sitcc_inside" Nothing >> m'

168− let modRC x = x

213+ modRC rc = rc

169 { rcIndent = max i c

214 { rcIndent = max i c

170 }

215 }

171− R m = traceR "sitcc_inside" Nothing >> m'

172 vlayout m' (R (local modRC m))

216 vlayout m' (R (local modRC m))

173 traceR "sitcc_ended" Nothing

217 traceR "sitcc_ended" Nothing

174

218

@@ -179,7 +223,7 @@ sitcc m' = do

179relaxComments :: R () -> R ()

223relaxComments :: R () -> R ()

180relaxComments (R m) = do

224relaxComments (R m) = do

181 traceR "relax_start" Nothing

225 traceR "relax_start" Nothing

182− let modRC x = x

226+ let modRC rc = rc

183 { rcRelaxedComments = True

227 { rcRelaxedComments = True

184 }

228 }

185 R (local modRC m)

229 R (local modRC m)

@@ -194,7 +238,7 @@ enterLayout l (R m) = do

194 SingleLine -> "single_line"

238 SingleLine -> "single_line"

195 MultiLine -> "multi_line"

239 MultiLine -> "multi_line"

196 traceR ("lstart_" ++ label) Nothing

240 traceR ("lstart_" ++ label) Nothing

197− let modRC x = x

241+ let modRC rc = rc

198 { rcLayout = l

242 { rcLayout = l

199 }

243 }

200 R (local modRC m)

244 R (local modRC m)

@@ -207,25 +251,91 @@ vlayout

207 -> R () -- ^ Multi line

251 -> R () -- ^ Multi line

208 -> R ()

252 -> R ()

209vlayout sline mline = do

253vlayout sline mline = do

210− l <- currentLayout

254+ l <- R (asks rcLayout)

211 case l of

255 case l of

212 SingleLine -> sline

256 SingleLine -> sline

213 MultiLine -> mline

257 MultiLine -> mline

214

258

215−-- | Return current layout.

216−

217−currentLayout :: R Layout

218−currentLayout = R (asks rcLayout)

219−

220-- | Check whether we're in a region with relaxed comments placement.

259-- | Check whether we're in a region with relaxed comments placement.

221

260

222relaxedComments :: R Bool

261relaxedComments :: R Bool

223relaxedComments = R (asks rcRelaxedComments)

262relaxedComments = R (asks rcRelaxedComments)

224

263

225−-- | Lookup an annotation.

264+----------------------------------------------------------------------------

265+-- Special helpers for comment placement

266+

267+-- | Drop elements that begin before or at the same place as given

268+-- 'SrcSpan'.

226

269

227−lookupAnn :: Data a => Located a -> R (Maybe Annotation)

270+trimSpanStream

228−lookupAnn l = M.lookup (mkAnnKey l) <$> R (asks rcAnns)

271+ :: RealSrcSpan -- ^ Reference span

272+ -> R ()

273+trimSpanStream ref = do

274+ let leRef :: RealSrcSpan -> Bool

275+ leRef x = realSrcSpanStart x <= realSrcSpanStart ref

276+ R . modify $ \sc -> sc

277+ { scSpanStream = coerce (dropWhile leRef) (scSpanStream sc)

278+ }

279+

280+-- | Get location of next element in AST.

281+

282+nextEltSpan :: R (Maybe RealSrcSpan)

283+nextEltSpan = listToMaybe . coerce <$> R (gets scSpanStream)

284+

285+-- | Pop a 'Comment' from the 'CommentStream' if given predicate is

286+-- satisfied and there are comments in the stream.

287+

288+popComment

289+ :: (RealLocated Comment -> Bool)

290+ -> R (Maybe (RealLocated Comment))

291+popComment f = R $ do

292+ CommentStream cstream <- gets scCommentStream

293+ case cstream of

294+ [] -> return Nothing

295+ (x:xs) ->

296+ if f x

297+ then Just x <$ modify (\sc -> sc

298+ { scCommentStream = CommentStream xs

299+ })

300+ else return Nothing

301+

302+-- | Return 'True' if there are more comments in the 'CommentStream'.

303+

304+hasMoreComments :: R Bool

305+hasMoreComments = R $ do

306+ CommentStream cstream <- gets scCommentStream

307+ (return . not . null) cstream

308+

309+-- | Current indentation level.

310+

311+getIndent :: R Int

312+getIndent = R (asks rcIndent)

313+

314+-- | Set indentation level.

315+

316+setIndent :: Int -> R () -> R ()

317+setIndent i m' = do

318+ traceR "set_indent_before" Nothing

319+ let R m = traceR "set_indent_inside" Nothing >> m'

320+ modRC rc = rc

321+ { rcIndent = i

322+ }

323+ R (local modRC m)

324+ traceR "set_indent_after" Nothing

325+

326+-- | Get 'RealSrcSpan' of enclosing span, if any.

327+

328+getEnclosingSpan :: R (Maybe RealSrcSpan)

329+getEnclosingSpan = R (asks rcEnclosingSpan)

330+

331+-- | Set 'RealSrcSpan' of enclosing span for the given computation.

332+

333+withEnclosingSpan :: RealSrcSpan -> R () -> R ()

334+withEnclosingSpan spn (R m) = do

335+ let modRC rc = rc

336+ { rcEnclosingSpan = Just spn

337+ }

338+ R (local modRC m)

229

339

230----------------------------------------------------------------------------

340----------------------------------------------------------------------------

231-- Debug helpers

341-- Debug helpers

src/Ormolu/Printer/Meat/Common.hs−24

@@ -10,23 +10,17 @@ module Ormolu.Printer.Meat.Common

10 , p_rdrName'

11 , p_qualName

12 , p_ieWildcard

13− -- * Helpers

14 , opParens

13 , opParens

15− , combineSrcSpans'

16− , getSpan

17− , unL

18 )

14 )

19where

15where

20

16

21import Data.Char (isAlphaNum)

17import Data.Char (isAlphaNum)

22−import Data.List.NonEmpty (NonEmpty (..))

23import GHC hiding (GhcPs, IE)

18import GHC hiding (GhcPs, IE)

24import Module (Module (..))

19import Module (Module (..))

25import OccName (OccName (..))

20import OccName (OccName (..))

26import Ormolu.Printer.Combinators

21import Ormolu.Printer.Combinators

27import Outputable (Outputable (..), showSDocUnsafe)

22import Outputable (Outputable (..), showSDocUnsafe)

28import RdrName (RdrName (..), rdrNameOcc)

23import RdrName (RdrName (..), rdrNameOcc)

29−import SrcLoc (combineSrcSpans)

30

24

31p_hsmodName :: ModuleName -> R ()

25p_hsmodName :: ModuleName -> R ()

32p_hsmodName mname = do

26p_hsmodName mname = do

@@ -64,9 +58,6 @@ p_ieWildcard = \case

64 NoIEWildcard -> return ()

58 NoIEWildcard -> return ()

65 IEWildcard n -> parens (atom n)

59 IEWildcard n -> parens (atom n)

66

60

67−----------------------------------------------------------------------------

68−-- Helpers

69−

70-- | Put parentheses around the second argument if the 'Outputable' thing

61-- | Put parentheses around the second argument if the 'Outputable' thing

71-- consists only of punctuation characters.

62-- consists only of punctuation characters.

72

63

@@ -75,18 +66,3 @@ opParens x m =

75 if all (not . isAlphaNum) (showSDocUnsafe (ppr x))

66 if all (not . isAlphaNum) (showSDocUnsafe (ppr x))

76 then txt "(" >> m >> txt ")"

67 then txt "(" >> m >> txt ")"

77 else m

68 else m

78−

79−-- | Combine all source spans from the given list.

80−

81−combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan

82−combineSrcSpans' (x:|xs) = foldr combineSrcSpans x xs

83−

84−-- | Get source span from a 'Located' thing.

85−

86−getSpan :: Located e -> SrcSpan

87−getSpan (L spn _) = spn

88−

89−-- | Exact inner value from 'Located'.

90−

91−unL :: Located e -> e

92−unL (L _ e) = e

src/Ormolu/Printer/Meat/Declaration.hs+1−2

@@ -8,8 +8,7 @@ module Ormolu.Printer.Meat.Declaration

8 )

9where

10

11−import HsDecls

11+import GHC

12−import Language.Haskell.GHC.ExactPrint.Types

13import Ormolu.Printer.Combinators

12import Ormolu.Printer.Combinators

14import Ormolu.Printer.Meat.Declaration.Data

13import Ormolu.Printer.Meat.Declaration.Data

15import Ormolu.Printer.Meat.Declaration.Type

14import Ormolu.Printer.Meat.Declaration.Type

src/Ormolu/Printer/Meat/Declaration/Data.hs+20−21

@@ -2,6 +2,8 @@

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE RecordWildCards #-}

4

5+-- | Renedring of data type declarations.

6+

5module Ormolu.Printer.Meat.Declaration.Data

7module Ormolu.Printer.Meat.Declaration.Data

6 ( p_dataDecl

8 ( p_dataDecl

7 )

9 )

@@ -9,13 +11,13 @@ where

9

11

10import BasicTypes (DerivStrategy (..))

12import BasicTypes (DerivStrategy (..))

11import Control.Monad

13import Control.Monad

12−import Data.List.NonEmpty (nonEmpty)

14+import Data.List.NonEmpty (NonEmpty (..))

13import Data.Maybe (isJust)

15import Data.Maybe (isJust)

14−import GHC hiding (GhcPs, IE)

16+import GHC

15−import Language.Haskell.GHC.ExactPrint.Types

16import Ormolu.Printer.Combinators

17import Ormolu.Printer.Combinators

17import Ormolu.Printer.Meat.Common

18import Ormolu.Printer.Meat.Common

18import Ormolu.Printer.Meat.Type

19import Ormolu.Printer.Meat.Type

20+import Ormolu.Utils (unL, getSpan, combineSrcSpans')

19import RdrName (RdrName (..))

21import RdrName (RdrName (..))

20import SrcLoc (Located)

22import SrcLoc (Located)

21

23

@@ -39,20 +41,17 @@ p_dataDecl name tvars HsDataDefn {..} = do

39 txt ":: "

41 txt ":: "

40 relaxComments (located k p_hsType)

42 relaxComments (located k p_hsType)

41 let gadt = isJust dd_kindSig || any (isGadt . unL) dd_cons

43 let gadt = isJust dd_kindSig || any (isGadt . unL) dd_cons

42− case nonEmpty dd_cons of

43− Nothing -> pure ()

44− Just dd_cons_ne ->

45− if gadt

44+ if gadt

46− then do

45+ then do

47− txt " where"

46+ txt " where"

48− newline

47+ newline

49− inci $ newlineSep (located' p_conDecl) dd_cons

48+ inci $ newlineSep (located' p_conDecl) dd_cons

50− else switchLayout (combineSrcSpans' (getSpan <$> dd_cons_ne)) $ do

49+ else switchLayout (combineSrcSpans' (getSpan name :| (getSpan <$> dd_cons))) $ do

51− breakpoint

50+ breakpoint

52− inci $ do

51+ inci $ do

53− txt "= "

52+ txt "= "

54− let sep = vlayout (txt " | ") (txt "| ")

53+ let sep = vlayout (txt " | ") (txt "| ")

55− velt $ withSep sep (located' p_conDecl) dd_cons

54+ velt $ withSep sep (located' p_conDecl) dd_cons

56 newline

55 newline

57 inci . located dd_derivs $ \xs ->

56 inci . located dd_derivs $ \xs ->

58 forM_ xs (line . located' p_hsDerivingClause)

57 forM_ xs (line . located' p_hsDerivingClause)

@@ -60,7 +59,7 @@ p_dataDecl name tvars HsDataDefn {..} = do

60p_conDecl :: ConDecl GhcPs -> R ()

59p_conDecl :: ConDecl GhcPs -> R ()

61p_conDecl = \case

60p_conDecl = \case

62 ConDeclGADT {..} -> velt'

61 ConDeclGADT {..} -> velt'

63− [ spaceSep (located' p_rdrName') con_names

62+ [ spaceSep (located' p_rdrName) con_names

64 , inci $ do

63 , inci $ do

65 txt ":: "

64 txt ":: "

66 relaxComments (locatedVia Nothing (hsib_body con_type) p_hsType)

65 relaxComments (locatedVia Nothing (hsib_body con_type) p_hsType)

@@ -83,17 +82,17 @@ p_conDecl = \case

83 txt "=> "

82 txt "=> "

84 case con_details of

83 case con_details of

85 PrefixCon xs -> do

84 PrefixCon xs -> do

86− located con_name p_rdrName'

85+ located con_name p_rdrName

87 unless (null xs) breakpoint

86 unless (null xs) breakpoint

88 inci $ velt' (located' p_hsType <$> xs)

87 inci $ velt' (located' p_hsType <$> xs)

89 RecCon l -> do

88 RecCon l -> do

90− located con_name p_rdrName'

89+ located con_name p_rdrName

91 breakpoint

90 breakpoint

92 inci $ located l p_conDeclFields

91 inci $ located l p_conDeclFields

93 InfixCon x y -> velt'

92 InfixCon x y -> velt'

94 [ located x p_hsType

93 [ located x p_hsType

95 , inci $ velt'

94 , inci $ velt'

96− [ backticks (located con_name p_rdrName')

95+ [ backticks (located con_name p_rdrName)

97 , inci $ located y p_hsType

96 , inci $ located y p_hsType

98 ]

97 ]

99 ]

98 ]

src/Ormolu/Printer/Meat/Declaration/Type.hs+1−2

@@ -9,8 +9,7 @@ module Ormolu.Printer.Meat.Declaration.Type

9where

10

11import Control.Monad

12−import HsTypes

12+import GHC

13−import Language.Haskell.GHC.ExactPrint.Types

14import Ormolu.Printer.Combinators

13import Ormolu.Printer.Combinators

15import Ormolu.Printer.Meat.Common

14import Ormolu.Printer.Meat.Common

16import Ormolu.Printer.Meat.Type

15import Ormolu.Printer.Meat.Type

src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs+1−3

@@ -11,9 +11,7 @@ where

11

12import Control.Monad

13import Data.Maybe (maybeToList, isJust)

14−import HsDecls

14+import GHC

15−import HsTypes

16−import Language.Haskell.GHC.ExactPrint.Types

17import Ormolu.Printer.Combinators

15import Ormolu.Printer.Combinators

18import Ormolu.Printer.Meat.Common

16import Ormolu.Printer.Meat.Common

19import Ormolu.Printer.Meat.Type

17import Ormolu.Printer.Meat.Type

src/Ormolu/Printer/Meat/ImportExport.hs+1−2

@@ -11,9 +11,8 @@ module Ormolu.Printer.Meat.ImportExport

11where

12

13import Control.Monad

14−import GHC hiding (GhcPs, IE)

14+import GHC

15import HsImpExp (IE (..))

16−import Language.Haskell.GHC.ExactPrint.Types

17import Ormolu.Printer.Combinators

16import Ormolu.Printer.Combinators

18import Ormolu.Printer.Meat.Common

17import Ormolu.Printer.Meat.Common

19

18

src/Ormolu/Printer/Meat/Module.hs+6−1

@@ -9,9 +9,11 @@ module Ormolu.Printer.Meat.Module

9where

10

11import Control.Monad

12+import Data.Maybe (isJust)

12import GHC hiding (GhcPs, IE)

13import GHC hiding (GhcPs, IE)

13import Ormolu.Imports

14import Ormolu.Imports

14import Ormolu.Printer.Combinators

15import Ormolu.Printer.Combinators

16+import Ormolu.Printer.Comments

15import Ormolu.Printer.Meat.Common

17import Ormolu.Printer.Meat.Common

16import Ormolu.Printer.Meat.Declaration

18import Ormolu.Printer.Meat.Declaration

17import Ormolu.Printer.Meat.ImportExport

19import Ormolu.Printer.Meat.ImportExport

@@ -38,7 +40,10 @@ p_hsModule loc@(L moduleSpan hsModule) = do

38 inci (locatedVia Nothing hsmodExports' p_hsmodExports)

40 inci (locatedVia Nothing hsmodExports' p_hsmodExports)

39 breakpoint

41 breakpoint

40 txt "where"

42 txt "where"

41− unless (null hsmodImports) newline

43+ when (not (null hsmodImports) || not (null hsmodDecls)) newline

42 forM_ (sortImports hsmodImports) (located' p_hsmodImport)

44 forM_ (sortImports hsmodImports) (located' p_hsmodImport)

43 when (not (null hsmodImports) && not (null hsmodDecls)) newline

45 when (not (null hsmodImports) && not (null hsmodDecls)) newline

44 newlineSep (located' p_hsDecl) hsmodDecls

46 newlineSep (located' p_hsDecl) hsmodDecls

47+ trailingComments <- hasMoreComments

48+ when (trailingComments && isJust hsmodName) newline

49+ spitRemainingComments

src/Ormolu/Printer/Meat/Type.hs+1−2

@@ -12,8 +12,7 @@ module Ormolu.Printer.Meat.Type

12 )

13where

14

15−import GHC hiding (GhcPs, IE)

15+import GHC

16−import Language.Haskell.GHC.ExactPrint.Types

17import Ormolu.Printer.Combinators

16import Ormolu.Printer.Combinators

18import Ormolu.Printer.Meat.Common

17import Ormolu.Printer.Meat.Common

19

18

src/Ormolu/SpanStream.hsnew file+47

@@ -0,0 +1,47 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3+

4+-- | Build span stream of AST elements.

5+

6+module Ormolu.SpanStream

7+ ( SpanStream (..)

8+ , mkSpanStream

9+ )

10+where

11+

12+import Data.DList (DList)

13+import Data.Data (Data)

14+import Data.Generics (everything, ext2Q)

15+import Data.List (sortOn)

16+import Data.Typeable (cast)

17+import SrcLoc

18+import qualified Data.DList as D

19+

20+-- | A stream of 'RealSrcSpan's in ascending order. This allows us to tell

21+-- e.g. whether there is another \"located\" element of AST between current

22+-- element and comment we're considering for printing.

23+

24+newtype SpanStream = SpanStream [RealSrcSpan]

25+ deriving (Eq, Show, Data, Semigroup, Monoid)

26+

27+-- | Create 'SpanStream' from a data structure containing 'RealSrcSpan's.

28+

29+mkSpanStream

30+ :: Data a

31+ => a -- ^ Data structure to inspect (AST)

32+ -> SpanStream

33+mkSpanStream a

34+ = SpanStream

35+ . sortOn realSrcSpanStart

36+ . D.toList

37+ $ everything mappend (const mempty `ext2Q` queryLocated) a

38+ where

39+ queryLocated

40+ :: (Data e0, Data e1)

41+ => GenLocated e0 e1

42+ -> DList RealSrcSpan

43+ queryLocated (L mspn _) =

44+ case cast mspn :: Maybe SrcSpan of

45+ Nothing -> mempty

46+ Just (UnhelpfulSpan _) -> mempty

47+ Just (RealSrcSpan spn) -> D.singleton spn

src/Ormolu/Utils.hsnew file+31

@@ -0,0 +1,31 @@

1+module Ormolu.Utils

2+ ( combineSrcSpans'

3+ , isModule

4+ , unL

5+ , getSpan

6+ )

7+where

8+

9+import Data.Data (Data, showConstr, toConstr)

10+import Data.List.NonEmpty (NonEmpty (..))

11+import SrcLoc

12+

13+-- | Combine all source spans from the given list.

14+

15+combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan

16+combineSrcSpans' (x:|xs) = foldr combineSrcSpans x xs

17+

18+-- | Return 'True' if given element of AST is module.

19+

20+isModule :: Data a => a -> Bool

21+isModule x = showConstr (toConstr x) == "HsModule"

22+

23+-- | Exact inner value from 'Located'.

24+

25+unL :: Located e -> e

26+unL (L _ e) = e

27+

28+-- | Get source span from a 'Located' thing.

29+

30+getSpan :: GenLocated l e -> l

31+getSpan (L spn _) = spn

tests/Ormolu/Printer/CombinatorsSpec.hs+1−2

@@ -5,7 +5,6 @@ module Ormolu.Printer.CombinatorsSpec (spec) where

5import Ormolu.Printer.Combinators

6import Ormolu.Printer.Internal

7import Test.Hspec

8−import qualified Data.Map.Strict as M

9import qualified Data.Text.IO as T

8import qualified Data.Text.IO as T

10

9

11-- NOTE Testing combinators in separation is easy, but it's not very useful

10-- NOTE Testing combinators in separation is easy, but it's not very useful

@@ -97,7 +96,7 @@ rModuleHeader = do

97shouldRender :: R () -> FilePath -> Expectation

96shouldRender :: R () -> FilePath -> Expectation

98shouldRender m path = do

97shouldRender m path = do

99 expected <- T.readFile path

98 expected <- T.readFile path

100− runR False m M.empty `shouldBe` expected

99+ runR False m mempty mempty `shouldBe` expected

101

100

102-- | Render using single-line layout.

101-- | Render using single-line layout.

103

102