490720f · ormolu · git.iko.soy

CHANGELOG.md+3

compare with master

unifiedsplit

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

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

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

5

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

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

8+

6## Ormolu 0.0.4.0

9## Ormolu 0.0.4.0

7

10

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

11* 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 #-}

6+

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.

2+

3+{-# LANGUAGE OverloadedStrings #-}

4+

5+-- Avoid warning produced by TH.

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

7+

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 @@

1{-# LANGUAGE NondecreasingIndentation #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE TypeFamilies #-}

4−{-# LANGUAGE NoMonoLocalBinds #-}

5−

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

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

7-- NoMonoLocalBinds before TypeFamilies

5-- NoMonoLocalBinds before TypeFamilies

6+{-# LANGUAGE NoMonoLocalBinds #-}

8

7

9module Foo

8module Foo

10 ( bar,

9 ( bar,

expected-failures/Agda.txt+1−1

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

11Please, consider reporting the bug.

12

13Parsing 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

15 parse error on input `C.QName'

16Please, consider reporting the bug.

17

expected-failures/idris.txt+1−1

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

83Please, consider reporting the bug.

84

85Formatting is not idempotent:

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

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

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

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

89Please, consider reporting the bug.

ormolu.cabal+1

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

82 , Ormolu.Parser.CommentStream

83 , Ormolu.Parser.Pragma

84 , Ormolu.Parser.Result

85+ , Ormolu.Parser.Shebang

85 , Ormolu.Printer

86 , Ormolu.Printer

86 , Ormolu.Printer.Combinators

87 , Ormolu.Printer.Combinators

87 , Ormolu.Printer.Comments

88 , Ormolu.Printer.Comments

src/Ormolu/Parser.hs+9−6

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

32import Ormolu.Parser.Anns

33import Ormolu.Parser.CommentStream

34import Ormolu.Parser.Result

35+import Ormolu.Parser.Shebang

35import qualified Panic as GHC

36import qualified Panic as GHC

36import qualified Parser as GHC

37import qualified Parser as GHC

37import qualified StringBuffer as GHC

38import qualified StringBuffer as GHC

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

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

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

94 Just err -> Left err

95 Just err -> Left err

95 Nothing ->

96 Nothing ->

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

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

98+ mkCommentStream extraComments pstate

97 in Right

99 in Right

98 ParseResult

100 ParseResult

99 { prParsedSource = pmod,

101 { prParsedSource = pmod,

100 prAnns = mkAnns pstate,

102 prAnns = mkAnns pstate,

101− prCommentStream = comments,

103+ prStackHeader = stackHeader,

102− prExtensions = exts,

103 prShebangs = shebangs,

104 prShebangs = shebangs,

105+ prPragmas = pragmas,

106+ prCommentStream = comments,

104 prUseRecordDot = useRecordDot,

107 prUseRecordDot = useRecordDot,

105 prImportQualifiedPost =

108 prImportQualifiedPost =

106 GHC.xopt ImportQualifiedPost dynFlags

109 GHC.xopt ImportQualifiedPost dynFlags

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

154 buffer = GHC.stringToStringBuffer input

157 buffer = GHC.stringToStringBuffer input

155 parseState = GHC.mkPState flags buffer location

158 parseState = GHC.mkPState flags buffer location

156

159

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

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

158-- This handles LINE pragmas and shebangs.

161-- This handles LINE pragmas and shebangs.

159extractCommentsFromLines ::

162extractCommentsFromLines ::

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

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

161 FilePath ->

164 FilePath ->

162− -- | List of lines from that file

165+ -- | Contents of that file

163 String ->

166 String ->

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

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

165 (String, [Located String])

168 (String, [Located String])

166extractCommentsFromLines path =

169extractCommentsFromLines path =

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

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

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

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

7 ( CommentStream (..),

8 Comment (..),

9 mkCommentStream,

10− isShebang,

11 isPrevHaddock,

10 isPrevHaddock,

12 isMultilineComment,

11 isMultilineComment,

13 showCommentStream,

12 showCommentStream,

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

16

15

17import Data.Char (isSpace)

16import Data.Char (isSpace)

18import Data.Data (Data)

17import Data.Data (Data)

19−import Data.Either (partitionEithers)

18+import qualified Data.List as L

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

21import Data.List.NonEmpty (NonEmpty (..))

19import Data.List.NonEmpty (NonEmpty (..))

22import qualified Data.List.NonEmpty as NE

20import qualified Data.List.NonEmpty as NE

23import Data.Maybe (mapMaybe)

21import Data.Maybe (mapMaybe)

24import qualified GHC

22import qualified GHC

25import qualified Lexer as GHC

23import qualified Lexer as GHC

26import Ormolu.Parser.Pragma

24import Ormolu.Parser.Pragma

25+import Ormolu.Parser.Shebang

27import Ormolu.Utils (showOutputable)

26import Ormolu.Utils (showOutputable)

28import SrcLoc

27import SrcLoc

29

28

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

45 [Located String] ->

44 [Located String] ->

46 -- | Parser state to use for comment extraction

45 -- | Parser state to use for comment extraction

47 GHC.PState ->

46 GHC.PState ->

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

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

48+ ( Maybe (RealLocated Comment),

49+ [Shebang],

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

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

51+ CommentStream

52+ )

50mkCommentStream extraComments pstate =

53mkCommentStream extraComments pstate =

51− ( CommentStream $

54+ ( mstackHeader,

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

55+ shebangs,

53 pragmas,

56 pragmas,

54− shebangs

57+ CommentStream comments

55 )

58 )

56 where

59 where

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

60+ (comments, pragmas) = extractPragmas rawComments1

58− rawComments =

61+ (rawComments1, mstackHeader) = extractStackHeader rawComments0

62+ rawComments0 =

59− mapMaybe toRealSpan $

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

60 otherExtraComments

64 otherExtraComments

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

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

62 ++ concatMap

66 ++ concatMap

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

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

64 (GHC.annotations_comments pstate)

68 (GHC.annotations_comments pstate)

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

69+ (shebangs, otherExtraComments) = extractShebangs extraComments

66−

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

68−isShebang :: String -> Bool

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

70

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

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

73isPrevHaddock :: Comment -> Bool

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

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

75

76-- | Is this comment multiline-style?

77isMultilineComment :: Comment -> Bool

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

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

79

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

81showCommentStream :: CommentStream -> String

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

94mkComment :: RealLocated String -> RealLocated Comment

95mkComment (L l s) =

96 L l . Comment . fmap dropTrailing $

97− if "{-" `isPrefixOf` s

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

98 then case NE.nonEmpty (lines s) of

99 Nothing -> s :| []

100 Just (x :| xs) ->

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

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

107 else s :| []

108 where

109− dropTrailing = dropWhileEnd isSpace

109+ dropTrailing = L.dropWhileEnd isSpace

110 startIndent = srcSpanStartCol l - 1

111

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

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

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

130toRealSpan _ = Nothing

131

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

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

133−-- Otherwise return the original comment unchanged.

133+extractStackHeader ::

134−partitionComments ::

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 ::

135− RealLocated String ->

149+ [RealLocated String] ->

136− Either (RealLocated String) Pragma

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

137−partitionComments input =

151+extractPragmas = go id id

152+ where

153+ go csSoFar pragmasSoFar = \case

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

155+ (x : xs) ->

138− case parsePragma (unRealSrcSpan input) of

156+ case parsePragma (unRealSrcSpan x) of

139− Nothing -> Left input

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

140− Just pragma -> Right pragma

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

11import Ormolu.Parser.Anns

12import Ormolu.Parser.CommentStream

13import Ormolu.Parser.Pragma (Pragma)

14+import Ormolu.Parser.Shebang (Shebang)

14

15

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

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

16data ParseResult = ParseResult

17data ParseResult = ParseResult

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

18 prParsedSource :: ParsedSource,

19 prParsedSource :: ParsedSource,

19 -- | Ormolu-specfic representation of annotations

20 -- | Ormolu-specfic representation of annotations

20 prAnns :: Anns,

21 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)],

21 -- | Comment stream

28 -- | Comment stream

22 prCommentStream :: CommentStream,

29 prCommentStream :: CommentStream,

23− -- | Extensions enabled in that module

24− prExtensions :: [Pragma],

25− -- | Shebangs found in the input

26− prShebangs :: [Located String],

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

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

28 prUseRecordDot :: Bool,

31 prUseRecordDot :: Bool,

29 -- | Whether or not ImportQualifiedPost is enabled

32 -- | Whether or not ImportQualifiedPost is enabled

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

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

1+{-# LANGUAGE DeriveDataTypeable #-}

2+

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 ::

21printModule ParseResult {..} =

22 runR

23 ( p_hsModule

24+ prStackHeader

24 prShebangs

25 prShebangs

25− prExtensions

26+ prPragmas

26 prImportQualifiedPost

27 prImportQualifiedPost

27 prParsedSource

28 prParsedSource

28 )

29 )

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

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

7 ( spitPrecedingComments,

8 spitFollowingComments,

9 spitRemainingComments,

10− spitStackHeader,

10+ spitCommentNow,

11+ spitCommentPending,

11 )

12 )

12where

13where

13

14

14import Control.Monad

15import Control.Monad

15−import Data.Char (isSpace)

16import Data.Coerce (coerce)

17import Data.Data (Data)

18−import Data.List (isPrefixOf)

19import qualified Data.List.NonEmpty as NE

18import qualified Data.List.NonEmpty as NE

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

21import qualified Data.Text as T

19import qualified Data.Text as T

22import Ormolu.Parser.CommentStream

20import Ormolu.Parser.CommentStream

23import Ormolu.Printer.Internal

21import Ormolu.Printer.Internal

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

55spitRemainingComments :: R ()

53spitRemainingComments :: R ()

56spitRemainingComments = void $ handleCommentSeries spitRemainingComment

54spitRemainingComments = void $ handleCommentSeries spitRemainingComment

57

55

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−

68----------------------------------------------------------------------------

56----------------------------------------------------------------------------

69-- Single-comment functions

57-- Single-comment functions

70

58

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

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

12import qualified Data.Text as T

13import GHC

14import Ormolu.Imports

15+import Ormolu.Parser.CommentStream

15import Ormolu.Parser.Pragma

16import Ormolu.Parser.Pragma

17+import Ormolu.Parser.Shebang

16import Ormolu.Printer.Combinators

18import Ormolu.Printer.Combinators

17import Ormolu.Printer.Comments

19import Ormolu.Printer.Comments

18import Ormolu.Printer.Meat.Common

20import Ormolu.Printer.Meat.Common

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

23

25

24-- | Render a module.

26-- | Render a module.

25p_hsModule ::

27p_hsModule ::

28+ -- | Stack header

29+ Maybe (RealLocated Comment) ->

26 -- | Shebangs

30 -- | Shebangs

27− [Located String] ->

31+ [Shebang] ->

28− -- | Pragmas

32+ -- | Pragmas and the associated comments

29− [Pragma] ->

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

30 -- | Whether to use postfix qualified imports

34 -- | Whether to use postfix qualified imports

31 Bool ->

35 Bool ->

32 -- | AST to print

36 -- | AST to print

33 ParsedSource ->

37 ParsedSource ->

34 R ()

38 R ()

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

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

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

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

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

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

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

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

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

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

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

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

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

42 switchLayout spans' $ do

46 switchLayout spans' $ do

43− forM_ shebangs $ \x ->

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

44 located x $ \shebang -> do

48 located x $ \shebang -> do

45 txt (T.pack shebang)

49 txt (T.pack shebang)

46 newline

50 newline

47− spitStackHeader

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

52+ spitCommentNow spn comment

53+ newline

48 newline

54 newline

49 p_pragmas pragmas

55 p_pragmas pragmas

50 newline

56 newline

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

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

8 )

9where

10

11+import Control.Monad

11import Data.Char (isUpper)

12import Data.Char (isUpper)

13+import qualified Data.List as L

12import Data.Maybe (listToMaybe)

14import Data.Maybe (listToMaybe)

13−import qualified Data.Set as S

14import qualified Data.Text as T

15import qualified Data.Text as T

16+import Ormolu.Parser.CommentStream

15import Ormolu.Parser.Pragma (Pragma (..))

17import Ormolu.Parser.Pragma (Pragma (..))

16import Ormolu.Printer.Combinators

18import Ormolu.Printer.Combinators

19+import Ormolu.Printer.Comments

20+import SrcLoc

17

21

18-- | Pragma classification.

22-- | Pragma classification.

19data PragmaTy

23data PragmaTy

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

42 Final

46 Final

43 deriving (Eq, Ord)

47 deriving (Eq, Ord)

44

48

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

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

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

46−p_pragmas ps =

51+p_pragmas ps = do

47− let prepare = concatMap $ \case

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

53+ analyze = \case

48− PragmaLanguage xs ->

54+ (cs, PragmaLanguage xs) ->

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

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

50 in f <$> xs

56 in f <$> xs

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

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

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

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

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

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

60+ p_pragma cs pragmaTy x

54

61

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

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

56−p_pragma ty c = do

63+p_pragma comments ty x = do

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

65+ spitCommentNow l comment

66+ newline

57 txt "{-# "

67 txt "{-# "

58 txt $ case ty of

68 txt $ case ty of

59 Language _ -> "LANGUAGE"

69 Language _ -> "LANGUAGE"

60 OptionsGHC -> "OPTIONS_GHC"

70 OptionsGHC -> "OPTIONS_GHC"

61 OptionsHaddock -> "OPTIONS_HADDOCK"

71 OptionsHaddock -> "OPTIONS_HADDOCK"

62 space

72 space

63− txt (T.pack c)

73+ txt (T.pack x)

64 txt " #-}"

74 txt " #-}"

65 newline

75 newline

66

76