120b4ca · ormolu · git.iko.soy

app/Main.hs+3−3

compare with master

unifiedsplit

@@ -4,16 +4,17 @@ import Control.Monad

4import Ormolu.Parser

5import Ormolu.Printer

6import System.Environment (getArgs)

7+import qualified Data.Text.IO as TIO

7import qualified Outputable as GHC

8import qualified Outputable as GHC

8

9

9main :: IO ()

10main :: IO ()

10main = do

11main = do

11 (path:_) <- getArgs

12 (path:_) <- getArgs

12 input <- readFile path

13 input <- readFile path

14+

13 (ws, r) <- parseModule [] path input

15 (ws, r) <- parseModule [] path input

14 unless (null ws) $

16 unless (null ws) $

15 putStrLn "dynamic option warnings:"

17 putStrLn "dynamic option warnings:"

16− -- TODO print ws

17 case r of

18 case r of

18 Left (srcSpan, err) -> do

19 Left (srcSpan, err) -> do

19 putStrLn (showOutputable srcSpan)

20 putStrLn (showOutputable srcSpan)

@@ -23,8 +24,7 @@ main = do

23 putStrLn (showOutputable anns)

24 putStrLn (showOutputable anns)

24 putStrLn "\nparsed module:\n"

25 putStrLn "\nparsed module:\n"

25 putStrLn (showOutputable parsedModule)

26 putStrLn (showOutputable parsedModule)

26−

27− printModule anns parsedModule

27+ TIO.putStr (printModule anns parsedModule)

28

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

30showOutputable = GHC.showSDocUnsafe . GHC.ppr

data/examples/module-header/double-shebangs-out.hsnew file+2

@@ -0,0 +1,2 @@

1+#!/usr/bin/env stack

2+#!/usr/bin/env stack

data/examples/module-header/double-shebangs.hsnew file+2

@@ -0,0 +1,2 @@

1+#!/usr/bin/env stack

2+#!/usr/bin/env stack

data/examples/module-header/empty-out.hsnew file

No changes to the content.

data/examples/module-header/empty.hsnew file

No changes to the content.

data/examples/module-header/multiline-out.hsnew file+6

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

1+module Foo

2+ ( foo

3+ , bar

4+ , baz

5+ )

6+where

data/examples/module-header/multiline-with-comments-out.hsnew file+21

@@ -0,0 +1,21 @@

1+-- | Header.

2+

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE TypeFamilies #-}

5+module My.Module

6+ ( -- * Something

7+ foo

8+ , bar

9+ , -- * Another thing

10+ (<?>)

11+ , {- some other thing -} foo2 -- yet another

12+ , foo3 -- third one

13+ , baz

14+ , bar2 -- a multiline comment

15+ -- the second line

16+ , bar3

17+ , module Foo.Bar.Baz

18+ )

19+where

20+

21+-- Wow

data/examples/module-header/multiline-with-comments.hsnew file+21

@@ -0,0 +1,21 @@

1+-- | Header.

2+

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE TypeFamilies #-}

5+

6+module My.Module

7+ ( -- * Something

8+ foo,

9+ bar,

10+ -- * Another thing

11+ (<?>),

12+ {- some other thing -} foo2 -- yet another

13+ ,foo3 -- third one

14+ ,baz,

15+ bar2 -- a multiline comment

16+ -- the second line

17+ ,bar3

18+ , module Foo.Bar.Baz )

19+where

20+

21+-- Wow

data/examples/module-header/multiline.hsnew file+2

@@ -0,0 +1,2 @@

1+module Foo (

2+ foo, bar, baz) where

data/examples/module-header/multiline2-out.hsnew file+6

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

1+module Foo

2+ ( foo

3+ , bar

4+ , baz

5+ )

6+where

data/examples/module-header/multiline2.hsnew file+2

@@ -0,0 +1,2 @@

1+module Foo

2+ (foo, bar, baz) where

data/examples/module-header/simple-out.hsnew file+1

@@ -0,0 +1 @@

1+module Main where

data/examples/module-header/simple-with-comments-out.hsnew file+4

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

1+-- | Here we go.

2+module Main where

3+

4+-- Wow.

data/examples/module-header/simple-with-comments.hsnew file+5

@@ -0,0 +1,5 @@

1+-- | Here we go.

2+

3+module Main where

4+

5+-- Wow.

data/examples/module-header/simple.hsnew file+1

@@ -0,0 +1 @@

1+module Main where

data/examples/module-header/singleline-out.hsnew file+1

@@ -0,0 +1 @@

1+module Foo (foo, bar, baz) where

data/examples/module-header/singleline.hsnew file+1

@@ -0,0 +1 @@

1+module Foo ( foo, bar, baz ) where

ormolu.cabal+14−5

@@ -13,7 +13,8 @@ build-type: Simple

13description: A formatter for Haskell source code.

14extra-doc-files: CHANGELOG.md

15 , README.md

16+data-files: data/examples/module-header/*.hs

16−data-files: data/printer/*.hs

17+ , data/printer/*.hs

17

18

18source-repository head

19source-repository head

19 type: git

20 type: git

@@ -28,17 +29,20 @@ library

28 hs-source-dirs: src

29 hs-source-dirs: src

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

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

30 , containers >= 0.5 && < 0.7

31 , containers >= 0.5 && < 0.7

32+ , exceptions >= 0.6 && < 0.11

31 , ghc >= 8.4.3

33 , ghc >= 8.4.3

32 , ghc-boot-th >= 8.4.3

34 , ghc-boot-th >= 8.4.3

33 , ghc-exactprint >= 0.5.6

35 , ghc-exactprint >= 0.5.6

34 , mtl >= 2.0 && < 3.0

36 , mtl >= 2.0 && < 3.0

35 , text >= 0.2 && < 1.3

37 , text >= 0.2 && < 1.3

36 exposed-modules: Ormolu

38 exposed-modules: Ormolu

39+ , Ormolu.Config

40+ , Ormolu.Diff

37 , Ormolu.Parser

41 , Ormolu.Parser

38 , Ormolu.Printer

42 , Ormolu.Printer

39 , Ormolu.Printer.Combinators

43 , Ormolu.Printer.Combinators

44+ , Ormolu.Printer.Comments

40 , Ormolu.Printer.Internal

45 , Ormolu.Printer.Internal

41− , Ormolu.Type

42 if flag(dev)

46 if flag(dev)

43 ghc-options: -Wall -Werror -Wcompat

47 ghc-options: -Wall -Werror -Wcompat

44 -Wincomplete-record-updates

48 -Wincomplete-record-updates

@@ -55,12 +59,16 @@ test-suite tests

55 type: exitcode-stdio-1.0

59 type: exitcode-stdio-1.0

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

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

57 , containers >= 0.5 && < 0.7

61 , containers >= 0.5 && < 0.7

62+ , filepath >= 1.2 && < 1.5

58 , hspec >= 2.0 && < 3.0

63 , hspec >= 2.0 && < 3.0

59 , ormolu

64 , ormolu

65+ , path >= 0.6 && < 0.7

66+ , path-io >= 1.4.2 && < 2.0

60 , text >= 0.2 && < 1.3

67 , text >= 0.2 && < 1.3

61− build-tools: hspec-discover >= 2.0 && < 3.0

68+ build-tools: hspec-discover >= 2.0 && < 3.0

62 other-modules:

69 other-modules:

63 Ormolu.Printer.CombinatorsSpec

70 Ormolu.Printer.CombinatorsSpec

71+ , Ormolu.PrinterSpec

64

72

65 if flag(dev)

73 if flag(dev)

66 ghc-options: -Wall -Werror

74 ghc-options: -Wall -Werror

@@ -71,9 +79,10 @@ test-suite tests

71executable ormolu

79executable ormolu

72 main-is: Main.hs

80 main-is: Main.hs

73 hs-source-dirs: app

81 hs-source-dirs: app

74− build-depends: base >= 4.8 && < 5.0

82+ build-depends: base >= 4.8 && < 5.0

75− , ghc >= 8.4.3

83+ , ghc >= 8.4.3

76 , ormolu

84 , ormolu

85+ , text >= 0.2 && < 1.3

77 if flag(dev)

86 if flag(dev)

78 ghc-options: -Wall -Werror -Wcompat

87 ghc-options: -Wall -Werror -Wcompat

79 -Wincomplete-record-updates

88 -Wincomplete-record-updates

src/Ormolu.hs+97−1

@@ -1,3 +1,99 @@

1+-- | A formatter for Haskell source code.

2+

3+{-# LANGUAGE RecordWildCards #-}

4+

1module Ormolu

5module Ormolu

6+ ( ormolu

7+ , ormoluFile

8+ , Config (..)

9+ , defaultConfig

10+ , DynOption (..)

11+ , OrmoluException (..)

2− ( )

12+ )

3where

13where

14+

15+import Control.Exception

16+import Control.Monad

17+import Control.Monad.Catch (MonadThrow (..))

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

19+import Data.Text (Text)

20+import Language.Haskell.GHC.ExactPrint.Types

21+import Ormolu.Config

22+import Ormolu.Diff

23+import Ormolu.Parser

24+import Ormolu.Printer

25+import qualified Data.Text as T

26+import qualified GHC

27+

28+-- | Format a 'String', return formatted version as 'Text'.

29+--

30+-- The function

31+--

32+-- * Takes 'String' because that's what GHC parser accepts.

33+-- * Needs 'IO' because some functions from GHC that are necessary to

34+-- setup parsing context require 'IO'. There should be no visible

35+-- side-effects though.

36+-- * Takes file name just to use it in parse error messages.

37+-- * Throws 'OrmoluException'.

38+

39+ormolu

40+ :: (MonadIO m, MonadThrow m)

41+ => Config -- ^ Ormolu configuration

42+ -> FilePath -- ^ Location of source file

43+ -> String -- ^ Input to format

44+ -> m Text

45+ormolu cfg path str = do

46+ (anns0, parsedSrc0) <-

47+ parseModule' cfg OrmoluParsingFailed path str

48+ let txt = printModule anns0 parsedSrc0

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

50+ -- same as AST of original snippet module span positions.

51+ (anns1, parsedSrc1) <-

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

53+ when (diff (anns0, parsedSrc0) (anns1, parsedSrc1)) $

54+ throwM (OrmoluASTDiffers str txt)

55+ return txt

56+

57+-- | Load a file and format it. The file stays intact and the rendered

58+-- version is returned as 'Text'.

59+--

60+-- > ormoluFile cfg path =

61+-- > liftIO (readFile path) >>= ormolu cfg path

62+

63+ormoluFile

64+ :: (MonadIO m, MonadThrow m)

65+ => Config -- ^ Ormolu configuration

66+ -> FilePath -- ^ Location of source file

67+ -> m Text -- ^ Resulting rendition

68+ormoluFile cfg path =

69+ liftIO (readFile path) >>= ormolu cfg path

70+

71+-- | A wrapper around 'parseModule'.

72+

73+parseModule'

74+ :: (MonadIO m, MonadThrow m)

75+ => Config -- ^ Ormolu configuration

76+ -> (GHC.SrcSpan -> String -> OrmoluException)

77+ -- ^ How to obtain 'OrmoluException' to throw when parsing fails

78+ -> FilePath -- ^ File name to use in errors

79+ -> String -- ^ Actual input for the parser

80+ -> m (Anns, GHC.ParsedSource) -- ^ Annotations and parsed source

81+parseModule' Config {..} mkException path str = do

82+ (_, r) <- liftIO (parseModule cfgDynOptions path str)

83+ case r of

84+ Left (spn, err) -> throwM (mkException spn err)

85+ Right x -> return x

86+

87+-- | Ormolu exception representing all cases when 'ormoluFile' can fail.

88+

89+data OrmoluException

90+ = OrmoluParsingFailed GHC.SrcSpan String

91+ -- ^ Parsing of original source code failed

92+ | OrmoluOutputParsingFailed GHC.SrcSpan String

93+ -- ^ Parsing of formatted source code failed

94+ | OrmoluASTDiffers String Text

95+ -- ^ Original and resulting ASTs differ, first argument is the original

96+ -- source code, second argument is rendered source code

97+ deriving (Eq, Show)

98+

99+instance Exception OrmoluException

src/Ormolu/Type.hs → src/Ormolu/Config.hsrenamed+5−5

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

1−-- | Types used in the library.

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

2

3−module Ormolu.Type

3+module Ormolu.Config

4 ( Config (..)

5 , defaultConfig

6 , DynOption (..)

7− , dynOption

7+ , dynOptionToLocatedStr

8 )

9where

10

@@ -32,5 +32,5 @@ newtype DynOption = DynOption

32

33-- | Convert 'DynOption' to @'GHC.Located' 'String'@.

34

35−dynOption :: DynOption -> GHC.Located String

35+dynOptionToLocatedStr :: DynOption -> GHC.Located String

36−dynOption (DynOption o) = GHC.L GHC.noSrcSpan o

36+dynOptionToLocatedStr (DynOption o) = GHC.L GHC.noSrcSpan o

src/Ormolu/Diff.hsnew file+18

@@ -0,0 +1,18 @@

1+-- | Diffing GHC ASTs modulo span positions.

2+

3+module Ormolu.Diff

4+ ( diff

5+ )

6+where

7+

8+import GHC

9+import Language.Haskell.GHC.ExactPrint.Types

10+

11+-- | Return 'False' of two annotated ASTs are the same modulo span

12+-- positions.

13+

14+diff

15+ :: (Anns, ParsedSource) -- ^ First annotated AST

16+ -> (Anns, ParsedSource) -- ^ Second annotated AST

17+ -> Bool

18+diff _ _ = False -- TODO

src/Ormolu/Parser.hs+2−2

@@ -6,7 +6,7 @@ where

6

7import Language.Haskell.GHC.ExactPrint.Parsers hiding (parseModule)

8import Language.Haskell.GHC.ExactPrint.Types

9−import Ormolu.Type

9+import Ormolu.Config

10import qualified CmdLineParser as GHC

11import qualified DynFlags as GHC

12import qualified GHC hiding (parseModule)

@@ -21,5 +21,5 @@ parseModule

21parseModule dynOpts path input = ghcWrapper $ do

22 dynFlags0 <- initDynFlagsPure path input

23 (dynFlags1, _, ws) <-

24− GHC.parseDynamicFilePragma dynFlags0 (dynOption <$> dynOpts)

24+ GHC.parseDynamicFilePragma dynFlags0 (dynOptionToLocatedStr <$> dynOpts)

25 return (ws, parseModuleFromStringInternal dynFlags1 path input)

src/Ormolu/Printer.hs+107−18

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

1+{-# LANGUAGE LambdaCase #-}

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE RecordWildCards #-}

3

4

@@ -7,29 +8,117 @@ module Ormolu.Printer

7 ( printModule )

8 ( printModule )

8where

9where

9

10

10−import GHC

11+import Data.Char (isAlphaNum)

12+import Data.Text (Text)

13+import FieldLabel (FieldLbl (..))

14+import GHC hiding (GhcPs, IE)

15+import HsImpExp (IE (..))

11import Language.Haskell.GHC.ExactPrint.Types

16import Language.Haskell.GHC.ExactPrint.Types

17+import Module (Module (..))

18+import OccName (OccName (..))

12import Ormolu.Printer.Combinators

19import Ormolu.Printer.Combinators

13−import qualified Data.Text.IO as TIO

20+import Outputable (Outputable (..), showSDocUnsafe)

21+import RdrName (RdrName (..), rdrNameOcc)

22+import SrcLoc (combineSrcSpans)

14

23

15-- | Render a module.

24-- | Render a module.

16

25

17printModule

26printModule

18− :: Anns

27+ :: Anns -- ^ Annotations

19− -> ParsedSource

28+ -> ParsedSource -- ^ Parsed source

20− -> IO ()

29+ -> Text -- ^ Resulting rendition

21−printModule anns src = TIO.putStr $

30+printModule anns src =

22− runR True (p_HsModule src) anns

31+ runR False (p_HsModule src) anns

23

32

24p_HsModule :: ParsedSource -> R ()

33p_HsModule :: ParsedSource -> R ()

25−p_HsModule l =

34+p_HsModule loc@(L moduleSpan hsModule) = do

35+ -- NOTE If span of exports in multiline, the whole thing is multiline.

36+ -- This is especially important because span of module itself always seems

37+ -- to have length zero, so it's not reliable for layout selection.

38+ let spn =

39+ case hsmodExports hsModule of

40+ Nothing -> moduleSpan

41+ Just (L exportsSpan _) -> combineSrcSpans moduleSpan exportsSpan

26− located l $ \HsModule {..} ->

42+ locatedVia spn loc $ \HsModule {..} ->

27− p_hsmodName hsmodName

43+ case hsmodName of

28−

29−p_hsmodName :: Maybe (Located ModuleName) -> R ()

30−p_hsmodName Nothing = return ()

44+ Nothing -> pure ()

31−p_hsmodName (Just l) =

45+ Just hsmodName' -> line . velt' $

32− located l $ \moduleName -> do

46+ [ located hsmodName' p_hsmodName ] ++

33− line $ do

47+ (case hsmodExports of

48+ Nothing -> []

49+ Just hsmodExports' ->

50+ [ inci (locatedVia spn hsmodExports' p_hsmodExports)

51+ ])

52+ ++ [ txt "where"

53+ ]

54+

55+p_hsmodName :: ModuleName -> R ()

56+p_hsmodName mname = do

34− txt "module "

57+ txt "module "

35− atom moduleName

58+ atom mname

59+

60+p_hsmodExports :: [LIE GhcPs] -> R ()

61+p_hsmodExports xs = do

62+ parens . velt $ withSep comma (located' p_lie) xs

63+

64+p_lie :: IE GhcPs -> R ()

65+p_lie = \case

66+ IEVar l1 -> located l1 p_ieWrappedName

67+ IEThingAbs l1 -> located l1 p_ieWrappedName

68+ IEThingAll l1 -> do

69+ located l1 p_ieWrappedName

70+ txt " (..)"

71+ IEThingWith l1 w xs fls -> do

72+ located l1 p_ieWrappedName

73+ space

74+ p_ieWildcard w

75+ parens . velt $ withSep comma (located' p_ieWrappedName) xs

76+ parens . velt $ withSep comma (located' p_FieldLbl) fls

77+ IEModuleContents l1 -> located l1 p_hsmodName

78+ -- XXX I have no idea what these things are for.

79+ IEGroup _ _ -> return ()

80+ IEDoc _ -> return ()

81+ IEDocNamed _ -> return ()

82+

83+p_ieWrappedName :: IEWrappedName RdrName -> R ()

84+p_ieWrappedName = \case

85+ IEName l2 -> located l2 p_rdrName

86+ IEPattern l2 -> located l2 $ \x -> do

87+ txt "pattern "

88+ p_rdrName x

89+ IEType l2 -> located l2 $ \x -> do

90+ txt "type "

91+ p_rdrName x

92+

93+p_rdrName :: RdrName -> R ()

94+p_rdrName x = opParens (rdrNameOcc x) $ case x of

95+ Unqual occName -> atom occName

96+ Qual mname occName -> p_qualName mname occName

97+ Orig (Module _ mname) occName -> p_qualName mname occName

98+ Exact name -> atom name

99+

100+p_FieldLbl :: FieldLbl RdrName -> R ()

101+p_FieldLbl (FieldLabel x _ _) = atom x

102+

103+p_qualName :: ModuleName -> OccName -> R ()

104+p_qualName mname occName = do

105+ atom mname

106+ txt "."

107+ atom occName

108+

109+p_ieWildcard :: IEWildcard -> R ()

110+p_ieWildcard = \case

111+ NoIEWildcard -> return ()

112+ IEWildcard n -> parens (atom n)

113+

114+----------------------------------------------------------------------------

115+-- Helpers

116+

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

118+-- consists only of punctuation characters.

119+

120+opParens :: Outputable a => a -> R () -> R ()

121+opParens x m =

122+ if all (not . isAlphaNum) (showSDocUnsafe (ppr x))

123+ then txt "(" >> m >> txt ")"

124+ else m

src/Ormolu/Printer/Combinators.hs+81−8

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

1+{-# LANGUAGE LambdaCase #-}

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE RecordWildCards #-}

3

4

@@ -14,8 +15,11 @@ module Ormolu.Printer.Combinators

14 , newline

15 , newline

15 , inci

16 , inci

16 , located

17 , located

18+ , locatedVia

19+ , located'

17 , velt

20 , velt

18 , velt'

21 , velt'

22+ , withSep

19 -- ** Wrapping

23 -- ** Wrapping

20 , line

24 , line

21 , braces

25 , braces

@@ -26,14 +30,15 @@ module Ormolu.Printer.Combinators

26 , ofType

30 , ofType

27 , sarrow

31 , sarrow

28 , darrow

32 , darrow

33+ , space

29 )

34 )

30where

35where

31

36

32import Data.Data (Data)

37import Data.Data (Data)

33import Data.List (intersperse)

38import Data.List (intersperse)

34import Data.Text (Text)

39import Data.Text (Text)

35−import Debug.Trace

36import Language.Haskell.GHC.ExactPrint.Types

40import Language.Haskell.GHC.ExactPrint.Types

41+import Ormolu.Printer.Comments

37import Ormolu.Printer.Internal

42import Ormolu.Printer.Internal

38import Outputable (Outputable (..), showSDocUnsafe)

43import Outputable (Outputable (..), showSDocUnsafe)

39import SrcLoc

44import SrcLoc

@@ -57,22 +62,72 @@ atom = txt . T.pack . showSDocUnsafe . ppr

57-- that may be associated with the primitive and sets corresponding layout

62-- that may be associated with the primitive and sets corresponding layout

58-- for the inner computation.

63-- for the inner computation.

59

64

60−located :: Data a => Located a -> (a -> R ()) -> R ()

65+located

66+ :: Data a

67+ => Located a -- ^ Thing to enter

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

69+ -> R ()

61−located loc@(L l a) f = do

70+located loc@(L l _) = locatedVia l loc

62− -- TODO implement handling of comments properly

71+

72+-- | A special version of 'located' that allows to control layout using

73+-- externally provided span.

74+

75+locatedVia

76+ :: Data a

77+ => SrcSpan -- ^ Span that controls layout selection

78+ -> Located a -- ^ Thing to enter

79+ -> (a -> R ()) -- ^ How to renedr inner value

80+ -> R ()

81+locatedVia l' loc@(L l a) f = do

63 mann <- lookupAnn loc

82 mann <- lookupAnn loc

64 let m = enterLayout

83 let m = enterLayout

65− (if isOneLineSpan l

84+ (if isOneLineSpan l'

66 then SingleLine

85 then SingleLine

67 else MultiLine)

86 else MultiLine)

68 (f a)

87 (f a)

69 case mann of

88 case mann of

70 Nothing -> m

89 Nothing -> m

71 Just Ann {..} ->

90 Just Ann {..} ->

72− enterLayout MultiLine $ do

91+ enterLayout MultiLine . sitcc $ do

73− traceShow annPriorComments $ mapM_ atom annPriorComments

92+ -- There are three things in 'Ann' which contain comments:

93+

94+ let cmode =

95+ if annGetConstr a == CN "HsModule"

96+ then Module

97+ else Other

98+ (before, after) = partitionDPs cmode l annsDP

99+

100+ -- 'annPriorComments' contains comments that were directly placed

101+ -- before entities such as comments (in both styles) before function

102+ -- definitions and inline comments before smaller things like types

103+ -- and literals.

104+

105+ spitComments (addDecoration cmode Before l <$> annPriorComments)

106+

107+ -- Comments inside 'annsDP' marked with 'AnnComment' are trickier,

108+ -- they seem to contain everything that goes after the thing they

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

110+ -- comments that go before things. Exact location can only be

111+ -- deduced by analyzing the associated span.

112+

113+ -- traceShowM (before,after, decoratedElt)

114+

115+ spitComments before

74 m

116 m

75− traceShow annFollowingComments $ mapM_ atom annFollowingComments

117+ spitComments after

118+

119+ -- I wasn't able to find any case when 'annFollowingComments' is

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

121+ -- have an example of source code where it matters.

122+

123+-- | A version of 'located' with arguments flipped.

124+

125+located'

126+ :: Data a

127+ => (a -> R ()) -- ^ How to render inner value

128+ -> Located a -- ^ Thing to enter

129+ -> R ()

130+located' = flip located

76

131

77-- | Element of variable layout. This means that the sub-components may be

132-- | Element of variable layout. This means that the sub-components may be

78-- rendered either on single line or each on its own line depending on

133-- rendered either on single line or each on its own line depending on

@@ -96,6 +151,19 @@ velt' xs = sitcc $ sequence_ (intersperse sep (sitcc <$> xs))

96 where

151 where

97 sep = vlayout (spit " ") newline

152 sep = vlayout (spit " ") newline

98

153

154+-- | Put separator between renderings of items of a list.

155+

156+withSep

157+ :: R () -- ^ Separator

158+ -> (a -> R ()) -- ^ How to render list items

159+ -> [a] -- ^ List to render

160+ -> [R ()] -- ^ List of printing actions

161+withSep sep f = \case

162+ [] -> []

163+ (x:xs) ->

164+ let g a = sep >> f a

165+ in f x : fmap g xs

166+

99----------------------------------------------------------------------------

167----------------------------------------------------------------------------

100-- Wrapping

168-- Wrapping

101

169

@@ -158,3 +226,8 @@ sarrow = txt "-> "

158

226

159darrow :: R ()

227darrow :: R ()

160darrow = txt "=> "

228darrow = txt "=> "

229+

230+-- | Print single space.

231+

232+space :: R ()

233+space = txt " "

src/Ormolu/Printer/Comments.hsnew file+198

@@ -0,0 +1,198 @@

1+-- | Helpers for formatting of comments.

2+

3+{-# LANGUAGE LambdaCase #-}

4+{-# LANGUAGE OverloadedStrings #-}

5+

6+module Ormolu.Printer.Comments

7+ ( -- * Types

8+ Decoration (..)

9+ , Decorator (..)

10+ , Position (..)

11+ , CommentMode (..)

12+ -- * Functions for working with comments

13+ , spitComments

14+ , partitionDPs

15+ , addDecoration

16+ )

17+where

18+

19+import ApiAnnotation (AnnKeywordId (AnnModule))

20+import Control.Monad

21+import Data.Bifunctor

22+import Data.List (isPrefixOf)

23+import Data.Maybe (mapMaybe)

24+import Language.Haskell.GHC.ExactPrint.Types

25+import Ormolu.Printer.Internal

26+import SrcLoc

27+import qualified Data.Text as T

28+

29+-- | Placement instructions for comments.

30+

31+data Decoration

32+ = Decoration Decorator Decorator

33+ deriving (Eq, Show)

34+

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

36+

37+data Decorator

38+ = NoDec -- ^ Output nothing

39+ | SpaceDec -- ^ Output single space

40+ | NewlineDec -- ^ Output single newline

41+ deriving (Eq, Show)

42+

43+-- | Position: before vs after.

44+

45+data Position

46+ = Before -- ^ Before

47+ | After -- ^ After

48+ deriving (Eq, Show)

49+

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

51+

52+data CommentMode

53+ = Module -- ^ Module

54+ | Other -- ^ Other element

55+ deriving (Eq, Show)

56+

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

58+-- space between the comments when necessary.

59+

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

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

62+ let spitDecorator = \case

63+ NoDec -> return ()

64+ SpaceDec -> spit " "

65+ NewlineDec -> newline

66+ spitDecorator d0

67+ spitComment comment

68+ spitDecorator d1

69+

70+-- | Output a 'Comment'.

71+

72+spitComment :: Comment -> R ()

73+spitComment (Comment str _ _) =

74+ if isMultiline str

75+ then if isPragma str

76+ then handleOne (normalizePragma str)

77+ else forM_ (normalizeIndent str) handleOne

78+ else handleOne str

79+ where

80+ handleOne x = do

81+ ensureIndent

82+ spit (T.pack x)

83+ isMultiline x = not ("--" `isPrefixOf` x)

84+ isPragma x = "{-#" `isPrefixOf` x

85+ normalizeIndent = fmap (dropWhile (== ' ')) . lines

86+ normalizePragma = unwords . words

87+

88+-- | Partition annotations to get a collection of 'Comment's preceding a

89+-- definition and following it. Every 'Comment' has corresponding

90+-- 'Decoration' which is used to understand how to decorate it.

91+

92+partitionDPs

93+ :: CommentMode -- ^ For which type of element we prepare comments

94+ -> SrcSpan -- ^ Span of element the comments are attached to

95+ -> [(KeywordId, DeltaPos)] -- ^ Annotations

96+ -> ([(Comment, Decoration)], [(Comment, Decoration)])

97+partitionDPs cmode refSpan anns =

98+ case cmode of

99+ Module -> partitionDPsModule refSpan anns

100+ Other -> partitionDPsOther refSpan anns

101+

102+-- | Try to partition comments as if for a module.

103+

104+partitionDPsModule

105+ :: SrcSpan -- ^ Span of element the comments are attached to

106+ -> [(KeywordId, DeltaPos)] -- ^ Annotations

107+ -> ([(Comment, Decoration)], [(Comment, Decoration)])

108+partitionDPsModule refSpan

109+ = bimap (takeComments Before) (takeComments After)

110+ . break ((== G AnnModule) . fst)

111+ where

112+ takeComments pos = mapMaybe $ \(keywordId, dpos) -> do

113+ c <- annComment keywordId

114+ return (c, getDecoration Module pos refSpan (c, dpos))

115+

116+-- | Partition comments according to their spans (works for everything but

117+-- modules).

118+

119+partitionDPsOther

120+ :: SrcSpan -- ^ Span of element the comments are attached to

121+ -> [(KeywordId, DeltaPos)] -- ^ Annotations

122+ -> ([(Comment, Decoration)], [(Comment, Decoration)])

123+partitionDPsOther refSpan

124+ = bimap (fmap (addDecoration Other Before refSpan))

125+ (fixupLastDec . fmap (addDecoration Other After refSpan))

126+ . break (followedBySpan refSpan . commentIdentifier . fst)

127+ . mapMaybe annComment'

128+ where

129+ annComment' :: (KeywordId, DeltaPos) -> Maybe (Comment, DeltaPos)

130+ annComment' (keywordId, dpos) = do

131+ c <- annComment keywordId

132+ return (c, dpos)

133+ followedBySpan :: SrcSpan -> SrcSpan -> Bool

134+ followedBySpan spn0 spn1 =

135+ if srcSpanEnd spn0 < srcSpanStart spn1

136+ then True

137+ else False

138+

139+-- | Last following comment cannot be standalone because in that case we get

140+-- redundant newlines.

141+

142+fixupLastDec :: [(Comment, Decoration)] -> [(Comment, Decoration)]

143+fixupLastDec [] = []

144+fixupLastDec [(c, Decoration d0 _)] = [(c, Decoration d0 NoDec)]

145+fixupLastDec (c:cs) = c : fixupLastDec cs

146+

147+-- | If 'KeywordId' is a comment, extract it.

148+

149+annComment :: KeywordId -> Maybe Comment

150+annComment (AnnComment x) = Just x

151+annComment _ = Nothing

152+

153+-- | Replace 'DeltaPos' with 'Decoration'.

154+

155+addDecoration

156+ :: CommentMode -- ^ For which type of element we prepare comments

157+ -> Position -- ^ Is this for comments before or after?

158+ -> SrcSpan -- ^ Span of element the comments are attached to

159+ -> (Comment, DeltaPos) -- ^ Thing to decorate

160+ -> (Comment, Decoration)

161+addDecoration cmode pos refSpan (comment, dpos) =

162+ ( comment

163+ , getDecoration cmode pos refSpan (comment, dpos)

164+ )

165+

166+-- | Calculate decoration for a comment.

167+

168+getDecoration

169+ :: CommentMode -- ^ For which type of element we prepare comments

170+ -> Position -- ^ Is this for comment before or after?

171+ -> SrcSpan -- ^ Span of element the comments are attached to

172+ -> (Comment, DeltaPos) -- ^ Thing to decorate

173+ -> Decoration

174+getDecoration cmode pos refSpan (c, (DP (r, _))) =

175+ Decoration preceedingDec followingDec

176+ where

177+ preceedingDec =

178+ if sameLine

179+ then case pos of

180+ Before -> NoDec

181+ After -> SpaceDec

182+ else if r > 1

183+ then NewlineDec

184+ else NoDec

185+ followingDec =

186+ if sameLine

187+ then case pos of

188+ Before -> SpaceDec

189+ After -> NewlineDec

190+ else NewlineDec

191+ sameLine =

192+ case cmode of

193+ Module -> False

194+ Other ->

195+ case (refSpan, commentIdentifier c) of

196+ (RealSrcSpan spn0, RealSrcSpan spn1) ->

197+ srcSpanStartLine spn0 == srcSpanStartLine spn1

198+ (_, _) -> False

src/Ormolu/Printer/Internal.hs+1−1

@@ -200,7 +200,7 @@ lookupAnn :: Data a => Located a -> R (Maybe Annotation)

200lookupAnn (L s d) = do

201 anns <- R (asks rcAnns)

202 let k = AnnKey s (annGetConstr d)

203− traceShow k $ return (M.lookup k anns)

203+ return (M.lookup k anns)

204

205----------------------------------------------------------------------------

206-- Debug helpers

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

@@ -35,11 +35,9 @@ stdTest

35stdTest name m path = describe name $ do

36 let spath = "data/printer/" ++ path ++ "-single.hs"

37 mpath = "data/printer/" ++ path ++ "-multi.hs"

38− context "single-line" $

38+ it "single-line works" $

39− it "works as expected" $

40 singleLine m `shouldRender` spath

39 singleLine m `shouldRender` spath

41− context "multi-line" $

40+ it "multi-line works" $

42− it "works as expected" $

43 multiLine m `shouldRender` mpath

41 multiLine m `shouldRender` mpath

44

42

45----------------------------------------------------------------------------

43----------------------------------------------------------------------------

tests/Ormolu/PrinterSpec.hsnew file+76

@@ -0,0 +1,76 @@

1+{-# LANGUAGE TemplateHaskell #-}

2+

3+module Ormolu.PrinterSpec (spec) where

4+

5+import Control.Monad

6+import Control.Monad.IO.Class

7+import Data.List (isSuffixOf)

8+import Data.Text (Text)

9+import Ormolu

10+import Path

11+import Path.IO

12+import System.FilePath (addExtension, dropExtensions, splitExtensions)

13+import Test.Hspec

14+import qualified Data.Text as T

15+import qualified Data.Text.IO as T

16+

17+spec :: Spec

18+spec = do

19+ es <- runIO locateExamples

20+ forM_ es checkExample

21+

22+-- | Check a single given example.

23+

24+checkExample :: Path Rel File -> Spec

25+checkExample srcPath' = it (fromRelFile srcPath' ++ " works") $ do

26+ let srcPath = examplesDir </> srcPath'

27+ expectedOutputPath <- deriveOutput srcPath

28+ -- 1. Given input snippet of source code parse it and pretty print it.

29+ -- 2. Parse the result of pretty-printing again and make sure that AST

30+ -- is the same as AST of the original snippet. (This happens in

31+ -- 'ormoluFile' automatically.)

32+ formatted0 <- ormoluFile defaultConfig (fromRelFile srcPath)

33+ -- 3. Check the output against expected output. Thus all tests should

34+ -- include two files: input and expected output.

35+ expected <- (liftIO . T.readFile . fromRelFile) expectedOutputPath

36+ formatted0 `shouldMatch` expected

37+ -- 4. Check that running the formatter on the output produces the same

38+ -- output again (the transformation is idempotent).

39+ formatted1 <- ormolu defaultConfig "<formatted>" (T.unpack formatted0)

40+ formatted1 `shouldMatch` formatted0

41+

42+-- | Build list of examples for testing.

43+

44+locateExamples :: IO [Path Rel File]

45+locateExamples =

46+ filter isInput . snd <$> listDirRecurRel examplesDir

47+

48+-- | Does given path look like input path (as opposed to expected output

49+-- path)?

50+

51+isInput :: Path Rel File -> Bool

52+isInput path =

53+ let s = fromRelFile path

54+ (s', exts) = splitExtensions s

55+ in exts == ".hs" && not ("-out" `isSuffixOf` s')

56+

57+-- | For given path of input file return expected name of output.

58+

59+deriveOutput :: Path Rel File -> IO (Path Rel File)

60+deriveOutput path = parseRelFile $

61+ addExtension (dropExtensions (fromRelFile path) ++ "-out") "hs"

62+

63+-- | A version of 'shouldBe' that is specialized to comparing 'Text' values.

64+-- It also prints multi-line snippets in a more readable form.

65+

66+shouldMatch :: Text -> Text -> Expectation

67+shouldMatch actual expected =

68+ when (actual /= expected) . expectationFailure $ unlines

69+ [ "expected:"

70+ , T.unpack expected

71+ , "bot got:"

72+ , T.unpack actual

73+ ]

74+

75+examplesDir :: Path Rel Dir

76+examplesDir = $(mkRelDir "data/examples")