490720f · ormolu · git.iko.soy

git.iko.soy/ormolu

Preserve comments on pragmas

commit490720fedccc05c1a8530e29ad9b2b1c77153287 authorMark Karpov <markkarpov92@gmail.com> dateFri 17 Apr 2020, 12:20 (7 years ago) parent145f729

15 files changed+159−76

compare with master

unifiedsplit

CHANGELOG.md+3 data/examples/other/pragma-comments-out.hs+11 data/examples/other/pragma-comments.hs+11 data/examples/other/pragma-sorting-out.hs+1−2 expected-failures/Agda.txt+1−1 expected-failures/idris.txt+1−1 ormolu.cabal+1 src/Ormolu/Parser.hs+9−6 src/Ormolu/Parser/CommentStream.hs+49−29 src/Ormolu/Parser/Result.hs+7−4 src/Ormolu/Parser/Shebang.hs+27 src/Ormolu/Printer.hs+2−1 src/Ormolu/Printer/Comments.hs+2−14 src/Ormolu/Printer/Meat/Module.hs+12−6 src/Ormolu/Printer/Meat/Pragma.hs+22−12

CHANGELOG.md+3

@@ -3,6 +3,9 @@

33* Grouping of statements in `do`-blocks is now respected. [Issue

44 74](https://github.com/tweag/ormolu/issues/74).

6+* Comments on pragmas are now preserved. [Issue

7+ 216](https://github.com/tweag/ormolu/issues/216).

69## Ormolu 0.0.4.0

710

811* When given several files to format, Ormolu does not stop on the first

data/examples/other/pragma-comments-out.hsnew file+11

@@ -0,0 +1,11 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+-- TODO This extension is probably too dangerous, remove it.

3+{-# LANGUAGE RecordWildCards #-}

4+-- Avoid warning produced by TH.

5+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}

7+-- | Header comment.

8+module Foo

9+ (

10+ )

11+where

data/examples/other/pragma-comments.hsnew file+11

@@ -0,0 +1,11 @@

1+-- | Header comment.

3+{-# LANGUAGE OverloadedStrings #-}

5+-- Avoid warning produced by TH.

6+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}

8+-- TODO This extension is probably too dangerous, remove it.

9+{-# LANGUAGE RecordWildCards #-}

10+

11+module Foo () where

data/examples/other/pragma-sorting-out.hs+1−2

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

11{-# LANGUAGE NondecreasingIndentation #-}

22{-# LANGUAGE ScopedTypeVariables #-}

33{-# LANGUAGE TypeFamilies #-}

4−{-# LANGUAGE NoMonoLocalBinds #-}

5−

64-- This gap is necessary for stylish Haskell not to re-arrange

75-- NoMonoLocalBinds before TypeFamilies

6+{-# LANGUAGE NoMonoLocalBinds #-}

98module Foo

109 ( bar,

expected-failures/Agda.txt+1−1

@@ -11,7 +11,7 @@ Formatting is not idempotent:

1111Please, consider reporting the bug.

1212

1313Parsing of formatted code failed:

14− src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs<rendered>:525:7-13

14+ src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs<rendered>:524:7-13

1515 parse error on input `C.QName'

1616Please, consider reporting the bug.

1717

expected-failures/idris.txt+1−1

@@ -83,7 +83,7 @@ Formatting is not idempotent:

8383Please, consider reporting the bug.

8484

8585Formatting is not idempotent:

86− src/Idris/REPL.hs<rendered>:1271:33

86+ src/Idris/REPL.hs<rendered>:1270:33

8787 before: "ht c) _) = -- consta"

8888 after: "ht c) _) =\n -- cons"

8989Please, consider reporting the bug.

ormolu.cabal+1

@@ -82,6 +82,7 @@ library

8282 , Ormolu.Parser.CommentStream

8383 , Ormolu.Parser.Pragma

8484 , Ormolu.Parser.Result

85+ , Ormolu.Parser.Shebang

8586 , Ormolu.Printer

8687 , Ormolu.Printer.Combinators

8788 , Ormolu.Printer.Comments

src/Ormolu/Parser.hs+9−6

@@ -32,6 +32,7 @@ import Ormolu.Exception

3232import Ormolu.Parser.Anns

3333import Ormolu.Parser.CommentStream

3434import Ormolu.Parser.Result

35+import Ormolu.Parser.Shebang

3536import qualified Panic as GHC

3637import qualified Parser as GHC

3738import qualified StringBuffer as GHC

@@ -93,14 +94,16 @@ parseModule Config {..} path input' = liftIO $ do

9394 -- later stages; but we fail in those cases.

9495 Just err -> Left err

9596 Nothing ->

96− let (comments, exts, shebangs) = mkCommentStream extraComments pstate

97+ let (stackHeader, shebangs, pragmas, comments) =

98+ mkCommentStream extraComments pstate

9799 in Right

98100 ParseResult

99101 { prParsedSource = pmod,

100102 prAnns = mkAnns pstate,

101− prCommentStream = comments,

102− prExtensions = exts,

103+ prStackHeader = stackHeader,

103104 prShebangs = shebangs,

105+ prPragmas = pragmas,

106+ prCommentStream = comments,

104107 prUseRecordDot = useRecordDot,

105108 prImportQualifiedPost =

106109 GHC.xopt ImportQualifiedPost dynFlags

@@ -154,14 +157,14 @@ runParser parser flags filename input = GHC.unP parser parseState

154157 buffer = GHC.stringToStringBuffer input

155158 parseState = GHC.mkPState flags buffer location

156159

157−-- | Transform given lines possibly returning comments extracted from them.

160+-- | Transform given input possibly returning comments extracted from it.

158161-- This handles LINE pragmas and shebangs.

159162extractCommentsFromLines ::

160163 -- | File name, just to use in the spans

161164 FilePath ->

162− -- | List of lines from that file

165+ -- | Contents of that file

163166 String ->

164− -- | Adjusted lines together with comments extracted from them

167+ -- | Adjusted input with comments extracted from it

165168 (String, [Located String])

166169extractCommentsFromLines path =

167170 unlines' . unzip . zipWith (extractCommentFromLine path) [1 ..] . lines

src/Ormolu/Parser/CommentStream.hs+49−29

@@ -7,7 +7,6 @@ module Ormolu.Parser.CommentStream

77 ( CommentStream (..),

88 Comment (..),

99 mkCommentStream,

10− isShebang,

1110 isPrevHaddock,

1211 isMultilineComment,

1312 showCommentStream,

@@ -16,14 +15,14 @@ where

1615

1716import Data.Char (isSpace)

1817import Data.Data (Data)

19−import Data.Either (partitionEithers)

20−import Data.List (dropWhileEnd, isPrefixOf, sortOn)

18+import qualified Data.List as L

2119import Data.List.NonEmpty (NonEmpty (..))

2220import qualified Data.List.NonEmpty as NE

2321import Data.Maybe (mapMaybe)

2422import qualified GHC

2523import qualified Lexer as GHC

2624import Ormolu.Parser.Pragma

25+import Ormolu.Parser.Shebang

2726import Ormolu.Utils (showOutputable)

2827import SrcLoc

2928

@@ -45,37 +44,38 @@ mkCommentStream ::

4544 [Located String] ->

4645 -- | Parser state to use for comment extraction

4746 GHC.PState ->

48− -- | Comment stream, a set of extracted pragmas, and extracted shebangs

49− (CommentStream, [Pragma], [Located String])

47+ -- | Stack header, shebangs, pragmas, and comment stream

48+ ( Maybe (RealLocated Comment),

49+ [Shebang],

50+ [([RealLocated Comment], Pragma)],

51+ CommentStream

52+ )

5053mkCommentStream extraComments pstate =

51− ( CommentStream $

52− mkComment <$> sortOn (realSrcSpanStart . getRealSrcSpan) comments,

54+ ( mstackHeader,

55+ shebangs,

5356 pragmas,

54− shebangs

57+ CommentStream comments

5558 )

5659 where

57− (comments, pragmas) = partitionEithers (partitionComments <$> rawComments)

58− rawComments =

59− mapMaybe toRealSpan $

60+ (comments, pragmas) = extractPragmas rawComments1

61+ (rawComments1, mstackHeader) = extractStackHeader rawComments0

62+ rawComments0 =

63+ L.sortOn (realSrcSpanStart . getRealSrcSpan) . mapMaybe toRealSpan $

6064 otherExtraComments

6165 ++ mapMaybe (liftMaybe . fmap unAnnotationComment) (GHC.comment_q pstate)

6266 ++ concatMap

6367 (mapMaybe (liftMaybe . fmap unAnnotationComment) . snd)

6468 (GHC.annotations_comments pstate)

65− (shebangs, otherExtraComments) = span (isShebang . unLoc) extraComments

66−

67−-- | Return 'True' if given 'String' is a shebang.

68−isShebang :: String -> Bool

69−isShebang str = "#!" `isPrefixOf` str

69+ (shebangs, otherExtraComments) = extractShebangs extraComments

7070

7171-- | Test whether a 'Comment' looks like a Haddock following a definition,

7272-- i.e. something starting with @-- ^@.

7373isPrevHaddock :: Comment -> Bool

74−isPrevHaddock (Comment (x :| _)) = "-- ^" `isPrefixOf` x

74+isPrevHaddock (Comment (x :| _)) = "-- ^" `L.isPrefixOf` x

7575

7676-- | Is this comment multiline-style?

7777isMultilineComment :: Comment -> Bool

78−isMultilineComment (Comment (x :| _)) = "{-" `isPrefixOf` x

78+isMultilineComment (Comment (x :| _)) = "{-" `L.isPrefixOf` x

7979

8080-- | Pretty-print a 'CommentStream'.

8181showCommentStream :: CommentStream -> String

@@ -94,7 +94,7 @@ showCommentStream (CommentStream xs) =

9494mkComment :: RealLocated String -> RealLocated Comment

9595mkComment (L l s) =

9696 L l . Comment . fmap dropTrailing $

97− if "{-" `isPrefixOf` s

97+ if "{-" `L.isPrefixOf` s

9898 then case NE.nonEmpty (lines s) of

9999 Nothing -> s :| []

100100 Just (x :| xs) ->

@@ -106,7 +106,7 @@ mkComment (L l s) =

106106 in x :| (drop n <$> xs)

107107 else s :| []

108108 where

109− dropTrailing = dropWhileEnd isSpace

109+ dropTrailing = L.dropWhileEnd isSpace

110110 startIndent = srcSpanStartCol l - 1

111111

112112-- | Get a 'String' from 'GHC.AnnotationComment'.

@@ -129,12 +129,32 @@ toRealSpan :: Located a -> Maybe (RealLocated a)

129129toRealSpan (L (RealSrcSpan l) a) = Just (L l a)

130130toRealSpan _ = Nothing

131131

132−-- | If a given comment is a pragma, return it in parsed form in 'Right'.

133−-- Otherwise return the original comment unchanged.

134−partitionComments ::

135− RealLocated String ->

136− Either (RealLocated String) Pragma

137−partitionComments input =

138− case parsePragma (unRealSrcSpan input) of

139− Nothing -> Left input

140− Just pragma -> Right pragma

132+-- | Detect and extract stack header if it is present.

133+extractStackHeader ::

134+ [RealLocated String] ->

135+ ([RealLocated String], Maybe (RealLocated Comment))

136+extractStackHeader = \case

137+ [] -> ([], Nothing)

138+ (x : xs) ->

139+ let comment = mkComment x

140+ in if isStackHeader (unRealSrcSpan comment)

141+ then (xs, Just comment)

142+ else (x : xs, Nothing)

143+ where

144+ isStackHeader (Comment (x :| _)) =

145+ "stack" `L.isPrefixOf` dropWhile isSpace (drop 2 x)

146+

147+-- | Extract pragmas and their associated comments.

148+extractPragmas ::

149+ [RealLocated String] ->

150+ ([RealLocated Comment], [([RealLocated Comment], Pragma)])

151+extractPragmas = go id id

152+ where

153+ go csSoFar pragmasSoFar = \case

154+ [] -> (csSoFar [], pragmasSoFar [])

155+ (x : xs) ->

156+ case parsePragma (unRealSrcSpan x) of

157+ Nothing -> go (csSoFar . (mkComment x :)) pragmasSoFar xs

158+ Just pragma ->

159+ let combined = (csSoFar [], pragma)

160+ in go id (pragmasSoFar . (combined :)) xs

src/Ormolu/Parser/Result.hs+7−4

@@ -11,6 +11,7 @@ import GHC

1111import Ormolu.Parser.Anns

1212import Ormolu.Parser.CommentStream

1313import Ormolu.Parser.Pragma (Pragma)

14+import Ormolu.Parser.Shebang (Shebang)

1415

1516-- | A collection of data that represents a parsed module in Ormolu.

1617data ParseResult = ParseResult

@@ -18,12 +19,14 @@ data ParseResult = ParseResult

1819 prParsedSource :: ParsedSource,

1920 -- | Ormolu-specfic representation of annotations

2021 prAnns :: Anns,

22+ -- | Stack header

23+ prStackHeader :: Maybe (RealLocated Comment),

24+ -- | Shebangs found in the input

25+ prShebangs :: [Shebang],

26+ -- | Pragmas and the associated comments

27+ prPragmas :: [([RealLocated Comment], Pragma)],

2128 -- | Comment stream

2229 prCommentStream :: CommentStream,

23− -- | Extensions enabled in that module

24− prExtensions :: [Pragma],

25− -- | Shebangs found in the input

26− prShebangs :: [Located String],

2730 -- | Whether or not record dot syntax is enabled

2831 prUseRecordDot :: Bool,

2932 -- | Whether or not ImportQualifiedPost is enabled

src/Ormolu/Parser/Shebang.hsnew file+27

@@ -0,0 +1,27 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

3+-- | A module for dealing with shebangs.

4+module Ormolu.Parser.Shebang

5+ ( Shebang (..),

6+ extractShebangs,

7+ isShebang,

8+ )

9+where

10+

11+import Data.Data (Data)

12+import qualified Data.List as L

13+import SrcLoc

14+

15+-- | A wrapper for a shebang.

16+newtype Shebang = Shebang (Located String)

17+ deriving (Eq, Data)

18+

19+-- | Extract shebangs from the beginning of a comment stream.

20+extractShebangs :: [Located String] -> ([Shebang], [Located String])

21+extractShebangs comments = (Shebang <$> shebangs, rest)

22+ where

23+ (shebangs, rest) = span (isShebang . unLoc) comments

24+

25+-- | Return 'True' if given 'String' is a shebang.

26+isShebang :: String -> Bool

27+isShebang str = "#!" `L.isPrefixOf` str

src/Ormolu/Printer.hs+2−1

@@ -21,8 +21,9 @@ printModule ::

2121printModule ParseResult {..} =

2222 runR

2323 ( p_hsModule

24+ prStackHeader

2425 prShebangs

25− prExtensions

26+ prPragmas

2627 prImportQualifiedPost

2728 prParsedSource

2829 )

src/Ormolu/Printer/Comments.hs+2−14

@@ -7,17 +7,15 @@ module Ormolu.Printer.Comments

77 ( spitPrecedingComments,

88 spitFollowingComments,

99 spitRemainingComments,

10− spitStackHeader,

10+ spitCommentNow,

11+ spitCommentPending,

1112 )

1213where

1314

1415import Control.Monad

15−import Data.Char (isSpace)

1616import Data.Coerce (coerce)

1717import Data.Data (Data)

18−import Data.List (isPrefixOf)

1918import qualified Data.List.NonEmpty as NE

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

2119import qualified Data.Text as T

2220import Ormolu.Parser.CommentStream

2321import Ormolu.Printer.Internal

@@ -55,16 +53,6 @@ spitFollowingComments ref = do

5553spitRemainingComments :: R ()

5654spitRemainingComments = void $ handleCommentSeries spitRemainingComment

5755

58−-- | If there is a stack header in the comment stream, print it.

59−spitStackHeader :: R ()

60−spitStackHeader = do

61− let isStackHeader (Comment (x :| _)) =

62− "stack" `isPrefixOf` dropWhile isSpace (drop 2 x)

63− mstackHeader <- popComment (isStackHeader . unRealSrcSpan)

64− forM_ mstackHeader $ \(L spn x) -> do

65− spitCommentNow spn x

66− newline

67−

6856----------------------------------------------------------------------------

6957-- Single-comment functions

7058

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

@@ -12,7 +12,9 @@ import Control.Monad

1212import qualified Data.Text as T

1313import GHC

1414import Ormolu.Imports

15+import Ormolu.Parser.CommentStream

1516import Ormolu.Parser.Pragma

17+import Ormolu.Parser.Shebang

1618import Ormolu.Printer.Combinators

1719import Ormolu.Printer.Comments

1820import Ormolu.Printer.Meat.Common

@@ -23,16 +25,18 @@ import Ormolu.Printer.Meat.Pragma

2325

2426-- | Render a module.

2527p_hsModule ::

28+ -- | Stack header

29+ Maybe (RealLocated Comment) ->

2630 -- | Shebangs

27− [Located String] ->

28− -- | Pragmas

29− [Pragma] ->

31+ [Shebang] ->

32+ -- | Pragmas and the associated comments

33+ [([RealLocated Comment], Pragma)] ->

3034 -- | Whether to use postfix qualified imports

3135 Bool ->

3236 -- | AST to print

3337 ParsedSource ->

3438 R ()

35−p_hsModule shebangs pragmas qualifiedPost (L moduleSpan HsModule {..}) = do

39+p_hsModule mstackHeader shebangs pragmas qualifiedPost (L moduleSpan HsModule {..}) = do

3640 -- If span of exports in multiline, the whole thing is multiline. This is

3741 -- especially important because span of module itself always seems to have

3842 -- length zero, so it's not reliable for layout selection.

@@ -40,11 +44,13 @@ p_hsModule shebangs pragmas qualifiedPost (L moduleSpan HsModule {..}) = do

4044 deprecSpan = maybe [] (\(L s _) -> [s]) hsmodDeprecMessage

4145 spans' = exportSpans ++ deprecSpan ++ [moduleSpan]

4246 switchLayout spans' $ do

43− forM_ shebangs $ \x ->

47+ forM_ shebangs $ \(Shebang x) ->

4448 located x $ \shebang -> do

4549 txt (T.pack shebang)

4650 newline

47− spitStackHeader

51+ forM_ mstackHeader $ \(L spn comment) -> do

52+ spitCommentNow spn comment

53+ newline

4854 newline

4955 p_pragmas pragmas

5056 newline

src/Ormolu/Printer/Meat/Pragma.hs+22−12

@@ -8,12 +8,16 @@ module Ormolu.Printer.Meat.Pragma

88 )

99where

1010

11+import Control.Monad

1112import Data.Char (isUpper)

13+import qualified Data.List as L

1214import Data.Maybe (listToMaybe)

13−import qualified Data.Set as S

1415import qualified Data.Text as T

16+import Ormolu.Parser.CommentStream

1517import Ormolu.Parser.Pragma (Pragma (..))

1618import Ormolu.Printer.Combinators

19+import Ormolu.Printer.Comments

20+import SrcLoc

1721

1822-- | Pragma classification.

1923data PragmaTy

@@ -42,25 +46,31 @@ data LanguagePragmaClass

4246 Final

4347 deriving (Eq, Ord)

4448

45−p_pragmas :: [Pragma] -> R ()

46−p_pragmas ps =

47− let prepare = concatMap $ \case

48− PragmaLanguage xs ->

49− let f x = (Language (classifyLanguagePragma x), x)

49+-- | Print a collection of 'Pragma's with their associated comments.

50+p_pragmas :: [([RealLocated Comment], Pragma)] -> R ()

51+p_pragmas ps = do

52+ let prepare = L.sortOn snd . L.nub . concatMap analyze

53+ analyze = \case

54+ (cs, PragmaLanguage xs) ->

55+ let f x = (cs, (Language (classifyLanguagePragma x), x))

5056 in f <$> xs

51− PragmaOptionsGHC x -> [(OptionsGHC, x)]

52− PragmaOptionsHaddock x -> [(OptionsHaddock, x)]

53− in mapM_ (uncurry p_pragma) (S.toAscList . S.fromList . prepare $ ps)

57+ (cs, PragmaOptionsGHC x) -> [(cs, (OptionsGHC, x))]

58+ (cs, PragmaOptionsHaddock x) -> [(cs, (OptionsHaddock, x))]

59+ forM_ (prepare ps) $ \(cs, (pragmaTy, x)) ->

60+ p_pragma cs pragmaTy x

5461

55−p_pragma :: PragmaTy -> String -> R ()

56−p_pragma ty c = do

62+p_pragma :: [RealLocated Comment] -> PragmaTy -> String -> R ()

63+p_pragma comments ty x = do

64+ forM_ comments $ \(L l comment) -> do

65+ spitCommentNow l comment

66+ newline

5767 txt "{-# "

5868 txt $ case ty of

5969 Language _ -> "LANGUAGE"

6070 OptionsGHC -> "OPTIONS_GHC"

6171 OptionsHaddock -> "OPTIONS_HADDOCK"

6272 space

63− txt (T.pack c)

73+ txt (T.pack x)

6474 txt " #-}"

6575 newline

6676