ae40a33 · ormolu · git.iko.soy

git.iko.soy/ormolu

Sort language pragmas and fix their placement in modules

The approach we take here is parsing of language pragmas on creation of comment stream and then pretty-printing them in a separate block.

commitae40a33507da67ac03a889549b1a615885d765cc authorwaddlaw <ingronze@gmail.com> dateMon 1 Jul 2019, 11:56 (7 years ago) parent693814c

80 files changed+385−91

compare with master

unifiedsplit

data/examples/declaration/class/associated-data-out.hs+1

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

11{-# LANGUAGE TypeFamilies #-}

23class Foo a where

45 data FooBar a

data/examples/declaration/class/associated-type-defaults-out.hs+1

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

11{-# LANGUAGE TypeFamilies #-}

23class Foo a where

45 type FooBar a = Int

data/examples/declaration/class/associated-types-out.hs+1

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

11{-# LANGUAGE TypeFamilies #-}

23class Foo a where

45 type FooBar a

data/examples/declaration/class/multi-parameters-out.hs+1

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

11{-# LANGUAGE MultiParamTypeClasses #-}

23class Foo a b where

45 foo :: a -> b

data/examples/declaration/class/poly-kinded-classes-out.hs+1

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

11{-# LANGUAGE PolyKinds #-}

23class Foo (a :: k)

45class

data/examples/declaration/class/type-operators-out.hs+1

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

11{-# LANGUAGE MultiParamTypeClasses #-}

22{-# LANGUAGE TypeOperators #-}

34class (:$) a b

56class

data/examples/declaration/data/empty-out.hs+1

@@ -1,2 +1,3 @@

11{-# LANGUAGE EmptyDataDecls #-}

23data Foo

data/examples/declaration/data/existential-multiline-out.hs+1

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

11{-# LANGUAGE ExistentialQuantification #-}

23data Foo

34 = forall a. MkFoo a (a -> Bool)

45 | forall a. Eq a => MkBar a

data/examples/declaration/data/existential-out.hs+1

@@ -1,2 +1,3 @@

11{-# LANGUAGE ExistentialQuantification #-}

23data Foo = forall a. MkFoo a (a -> Bool)

data/examples/declaration/foreign/foreign-import-out.hs+1

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

11{-# LANGUAGE CApiFFI #-}

23foreign import ccall safe foo :: Int -> IO Int

45-- | 'bar' is a very important thing

data/examples/declaration/instance/associated-data-out.hs+1

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

11{-# LANGUAGE TypeFamilies #-}

23instance Foo Int where

45 data Bar Int = IntBar Int Int

data/examples/declaration/instance/associated-types-out.hs+1

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

11{-# LANGUAGE TypeFamilies #-}

23instance Foo Int where

45 type Bar Int = Double

data/examples/declaration/instance/data-family-instances-out.hs+1

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

11{-# LANGUAGE GADTSyntax #-}

22{-# LANGUAGE TypeFamilies #-}

34data instance Foo Int = FooInt Int

56data instance Foo [Int]

data/examples/declaration/instance/instance-sigs-out.hs+1

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

11{-# LANGUAGE InstanceSigs #-}

23instance Eq Int where

45 (==) :: Int -> Int -> Bool

data/examples/declaration/instance/type-family-instances-out.hs+1

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

11{-# LANGUAGE TypeFamilies #-}

23type instance Foo Int = Int

45type instance

data/examples/declaration/role-annotation/simple-out.hs+2−1

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

1−{-# LANGUAGE RoleAnnotations #-}

21{-# LANGUAGE MagicHash #-}

2+{-# LANGUAGE RoleAnnotations #-}

34type role Ptr representational

56type role A nominal nominal

data/examples/declaration/signature/pattern/multiline-out.hs+1

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

11{-# LANGUAGE PatternSynonyms #-}

23pattern Arrow

34 :: Type

45 -> Type

data/examples/declaration/signature/pattern/single-line-out.hs+1

@@ -1,2 +1,3 @@

11{-# LANGUAGE PatternSynonyms #-}

23pattern Arrow :: Type -> Type -> Type

data/examples/declaration/signature/type/arguments-out.hs+1

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

11{-# LANGUAGE RankNTypes #-}

23functionName

34 :: (C1, C2, C3, C4, C5)

45 => a

data/examples/declaration/splice/bracket-out.hs+1

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

11{-# LANGUAGE TemplateHaskell #-}

23foo =

34 [e|

45 foo bar

data/examples/declaration/splice/quasiquote-out.hs+1

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

11{-# LANGUAGE QuasiQuotes #-}

23x = [foo| foo bar |]

45x =

data/examples/declaration/splice/splice-decl-out.hs+1

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

11{-# LANGUAGE TemplateHaskell #-}

23$(foo bar)

45$foo

data/examples/declaration/splice/typed-splice-out.hs+1

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

11{-# LANGUAGE TemplateHaskell #-}

23x =

34 $$( foo bar

45 )

data/examples/declaration/splice/untyped-splice-out.hs+1

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

11{-# LANGUAGE TemplateHaskell #-}

23x = $(foo bar)

45x =

data/examples/declaration/value/function/arrow/expression-applications-out.hs+1

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

11{-# LANGUAGE Arrows #-}

23foo x y = x -< y

45bar f x =

data/examples/declaration/value/function/arrow/expression-forms-out.hs+1

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

11{-# LANGUAGE Arrows #-}

23foo f g x y = (|test (f -< x) (g -< y)|)

45bar f g x y =

data/examples/declaration/value/function/arrow/proc-applications-out.hs+1

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

11{-# LANGUAGE Arrows #-}

23foo x = proc a -> a -< x

45bar f x =

data/examples/declaration/value/function/arrow/proc-cases-out.hs+1

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

11{-# LANGUAGE Arrows #-}

23foo f = proc a -> case a of Left b -> f -< b

45bar f g h j = proc a -> case a of

data/examples/declaration/value/function/arrow/proc-do-complex-out.hs+1

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

11{-# LANGUAGE Arrows #-}

23foo

34 f

45 g

data/examples/declaration/value/function/arrow/proc-do-simple-out.hs+1

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

11{-# LANGUAGE Arrows #-}

23foo f = proc a -> do

34 f -< a

data/examples/declaration/value/function/arrow/proc-forms-out.hs+1

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

11{-# LANGUAGE Arrows #-}

23foo0 f g x y = proc _ -> (|f (g -< (x, y))|)

45foo1 f g h x = proc (y, z) ->

data/examples/declaration/value/function/arrow/proc-ifs-out.hs+1

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

11{-# LANGUAGE Arrows #-}

23foo f = proc a -> if a then f -< 0 else f -< 1

45bar f g = proc a ->

data/examples/declaration/value/function/arrow/proc-lambdas-out.hs+1

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

11{-# LANGUAGE Arrows #-}

23foo = proc a -> \f b -> a -< f b -- Foo

45bar = proc x -> \f g h -> \() -> \(Left (x, y)) -> -- Tuple value

data/examples/declaration/value/function/arrow/proc-lets-out.hs+1

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

11{-# LANGUAGE Arrows #-}

23foo f = proc a -> let b = a in f -< b

45bar f g = proc a ->

data/examples/declaration/value/function/arrow/proc-parentheses-out.hs+1

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

11{-# LANGUAGE Arrows #-}

23foo f = proc a -> (f -< a)

45bar f g = proc a ->

data/examples/declaration/value/function/arrow/recursive-procs-out.hs+1

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

11{-# LANGUAGE Arrows #-}

23foo f g = proc (x, y) -> do

34 rec a <- f y -< x

45 b <-

data/examples/declaration/value/function/do-out.hs+1

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

11{-# LANGUAGE RecursiveDo #-}

23bar = do

34 foo

45 bar

data/examples/declaration/value/function/implicit-params-out.hs+1

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

11{-# LANGUAGE ImplicitParams #-}

23sortBy :: (a -> a -> Bool) -> [a] -> [a]

45sort :: (?cmp :: a -> a -> Bool) => [a] -> [a]

data/examples/declaration/value/function/lambda-case-out.hs+1

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

11{-# LANGUAGE LambdaCase #-}

23foo :: Int -> Int

34foo = \case

45 5 -> 10

data/examples/declaration/value/function/multi-way-if-out.hs+1

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

11{-# LANGUAGE MultiWayIf #-}

23foo x = if | x == 5 -> 5

45bar x y =

data/examples/declaration/value/function/overloaded-labels-out.hs+1

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

11{-# LANGUAGE OverloadedLabels #-}

23foo = #field

45bar = (#this) (#that)

data/examples/declaration/value/function/pattern/n-plus-k-pattern-out.hs+1

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

11{-# LANGUAGE NPlusKPatterns #-}

23singleline :: Int

34singleline (n + 1) = n

data/examples/declaration/value/function/pattern/quasi-quotes-pattern-out.hs+1

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

11{-# LANGUAGE QuasiQuotes #-}

23singleline :: ()

34singleline [yamlQQ|something|] = ()

data/examples/declaration/value/function/pattern/splice-pattern-out.hs+1

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

11{-# LANGUAGE TemplateHaskell #-}

23singleLine = case () of

34 $x -> ()

45 $(y "something") -> ()

data/examples/declaration/value/function/pattern/view-pattern-out.hs+1

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

11{-# LANGUAGE ViewPatterns #-}

23example f (f -> 4) = True

45f (t -> Nothing) = "Nothing"

data/examples/declaration/value/function/quasi-quotes-out.hs+1

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

11{-# LANGUAGE QuasiQuotes #-}

23singleline :: Value

34singleline = [yamlQQ|something|]

data/examples/declaration/value/function/record-wildcards-out.hs+1

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

11{-# LANGUAGE NamedFieldPuns #-}

22{-# LANGUAGE RecordWildCards #-}

34foo x y = Foo {x, y}

56bar x y z = Bar

data/examples/declaration/value/function/splice-out.hs+1

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

11{-# LANGUAGE TemplateHaskell #-}

23bar = $bar

45bar' = $(bar "something")

data/examples/declaration/value/function/static-pointers-out.hs+1

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

11{-# LANGUAGE StaticPointers #-}

23foo :: StaticPtr Int

34foo = static 5

data/examples/declaration/value/function/tuple-sections-out.hs+1

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

11{-# LANGUAGE TupleSections #-}

23foo = (,2)

45bar = (,5,)

data/examples/declaration/value/function/type-applications-out.hs+1

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

11{-# LANGUAGE TypeApplications #-}

23foo = f @String a b c

45bar = f @(Maybe Int) a b

data/examples/declaration/value/function/unboxed-sums-out.hs+1

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

11{-# LANGUAGE UnboxedSums #-}

23foo = (# 1 | #)

45bar = (# | | 2 | #)

data/examples/declaration/value/function/unboxed-tuples-out.hs+1

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

11{-# LANGUAGE UnboxedTuples #-}

23foo = (# 1, 2, 3 #)

45bar =

data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional-out.hs+1

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

11{-# LANGUAGE PatternSynonyms #-}

23pattern HeadC x <-

34 x : xs

45 where

data/examples/declaration/value/pattern-synonyms/unidirectional-out.hs+1

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

11{-# LANGUAGE PatternSynonyms #-}

23pattern Head x <- x : xs

45pattern Head' x <-

data/examples/module-header/multiline-with-comments-out.hs+2−2

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

1−-- | Header.

2−

31{-# LANGUAGE FlexibleContexts #-}

42{-# LANGUAGE TypeFamilies #-}

4+-- | Header.

55module My.Module

66 ( -- * Something

77 foo

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

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

1+-- | This demonstrates a BUG.

2+module Foo

3+ (

4+ )

5+where

data/examples/module-header/singleline-empty.hsnew file+2

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

1+-- | This demonstrates a BUG.

2+module Foo () where

data/examples/other/language-pragma-no-header-out.hsnew file+3

@@ -0,0 +1,3 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE ViewPatterns #-}

data/examples/other/language-pragma-no-header.hsnew file+3

@@ -0,0 +1,3 @@

1+{-# LANGUAGE LambdaCase #-}

2+{-# LANGuagE ViewPatterns #-}

3+{-# language DataKinds, LambdaCase #-}

data/examples/other/language-pragma-out.hsnew file+9

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

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE ViewPatterns #-}

5+-- | Header comment.

6+module Foo

7+ (

8+ )

9+where

data/examples/other/language-pragma.hsnew file+7

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

1+-- | Header comment.

3+{-# LANGUAGE LambdaCase #-}

4+{-# LANGuagE ViewPatterns #-}

5+{-# language DataKinds, LambdaCase #-}

7+module Foo () where

ormolu.cabal+10−4

@@ -11,7 +11,9 @@ category: Development, Formatting

1111synopsis: A formatter for Haskell source code

1212build-type: Simple

1313description: A formatter for Haskell source code.

14−extra-doc-files: CHANGELOG.md

14+extra-doc-files: CONTRIBUTING.md

15+ , CHANGELOG.md

16+ , DESIGN.md

1517 , README.md

1618data-files: data/examples/declaration/data/*.hs

1719 , data/examples/declaration/data/gadt/*.hs

@@ -47,13 +49,15 @@ library

4749 , text >= 0.2 && < 1.3

4850 , yaml >= 0.8 && < 0.12

4951 exposed-modules: Ormolu

50− , Ormolu.Anns

51− , Ormolu.CommentStream

5252 , Ormolu.Config

5353 , Ormolu.Diff

5454 , Ormolu.Exception

5555 , Ormolu.Imports

5656 , Ormolu.Parser

57+ , Ormolu.Parser.Anns

58+ , Ormolu.Parser.CommentStream

59+ , Ormolu.Parser.LanguagePragma

60+ , Ormolu.Parser.Result

5761 , Ormolu.Printer

5862 , Ormolu.Printer.Combinators

5963 , Ormolu.Printer.Comments

@@ -74,9 +78,10 @@ library

7478 , Ormolu.Printer.Meat.Declaration.Value

7579 , Ormolu.Printer.Meat.Declaration.Warning

7680 , Ormolu.Printer.Meat.ImportExport

81+ , Ormolu.Printer.Meat.LanguagePragma

7782 , Ormolu.Printer.Meat.Module

7883 , Ormolu.Printer.Meat.Type

79− , Ormolu.SpanStream

84+ , Ormolu.Printer.SpanStream

8085 , Ormolu.Utils

8186 if flag(dev)

8287 ghc-options: -Wall -Werror -Wcompat

@@ -103,6 +108,7 @@ test-suite tests

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

104109 other-modules:

105110 Ormolu.Printer.CombinatorsSpec

111+ , Ormolu.Parser.LanguagePragmaSpec

106112 , Ormolu.PrinterSpec

107113

108114 if flag(dev)

src/Ormolu.hs+12−26

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

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

1919import Data.Text (Text)

2020import Debug.Trace

21−import Ormolu.Anns

22−import Ormolu.CommentStream

2321import Ormolu.Config

2422import Ormolu.Diff

2523import Ormolu.Exception

2624import Ormolu.Parser

25+import Ormolu.Parser.Result

2726import Ormolu.Printer

27+import Ormolu.Utils (showOutputable)

2828import qualified CmdLineParser as GHC

2929import qualified Data.Text as T

3030import qualified GHC

31−import qualified Outputable as GHC

3231

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

3433--

@@ -48,20 +47,19 @@ ormolu

4847 -> String -- ^ Input to format

4948 -> m Text

5049ormolu cfg path str = do

51− (ws, (cstream0, anns0, parsedSrc0)) <-

50+ (ws, result0) <-

5251 parseModule' cfg OrmoluParsingFailed path str

5352 when (cfgDebug cfg) $ do

5453 traceM "warnings:\n"

5554 traceM (concatMap showWarn ws)

56− traceM "comment stream:\n"

57− traceM (showCommentStream cstream0)

58− let txt = printModule (cfgDebug cfg) cstream0 anns0 parsedSrc0

55+ traceM (prettyPrintParseResult result0)

56+ let txt = printModule (cfgDebug cfg) result0

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

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

6159 unless (cfgUnsafe cfg) $ do

62− (_, (cstream1, _, parsedSrc1)) <-

60+ (_, result1) <-

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

64− when (diff (cstream0, parsedSrc0) (cstream1, parsedSrc1)) $

62+ when (diff result0 result1) $

6563 liftIO $ throwIO (OrmoluASTDiffers str txt)

6664 return txt

6765

@@ -91,8 +89,7 @@ parseModule'

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

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

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

94− -> m ([GHC.Warn], (CommentStream, Anns, GHC.ParsedSource))

95− -- ^ Comment stream and parsed source

92+ -> m ([GHC.Warn], ParseResult)

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

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

9895 case r of

@@ -102,18 +99,7 @@ parseModule' Config {..} mkException path str = do

10299-- | Pretty-print a 'GHC.Warn'.

103100

104101showWarn :: GHC.Warn -> String

105−showWarn (GHC.Warn reason l) =

106− showOutputable reason ++ "\n" ++ showOutputable l ++ "\n"

107−

108−-- | Pretty-print a 'CommentStream'.

109−

110−showCommentStream :: CommentStream -> String

111−showCommentStream (CommentStream xs) = unlines $

112− showComment <$> xs

113− where

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

115−

116−-- | Pretty-print an 'GHC.Outputable' thing.

117−

118−showOutputable :: GHC.Outputable o => o -> String

119−showOutputable = GHC.showSDocUnsafe . GHC.ppr

102+showWarn (GHC.Warn reason l) = unlines

103+ [ showOutputable reason

104+ , showOutputable l

105+ ]

src/Ormolu/Diff.hs+8−6

@@ -12,17 +12,19 @@ where

1212import BasicTypes (SourceText)

1313import Data.Generics

1414import GHC

15−import Ormolu.CommentStream

1615import Ormolu.Imports (sortImports)

16+import Ormolu.Parser.Result

1717

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

1919-- positions.

2020

21−diff

22− :: (CommentStream, ParsedSource) -- ^ First comment stream and AST

23− -> (CommentStream, ParsedSource) -- ^ Second comment stream and AST

24− -> Bool

25−diff (cstream0, ps0) (cstream1, ps1) =

21+diff :: ParseResult -> ParseResult -> Bool

22+diff ParseResult { prCommentStream = cstream0

23+ , prParsedSource = ps0

24+ }

25+ ParseResult { prCommentStream = cstream1

26+ , prParsedSource = ps1

27+ } =

2628 not (matchIgnoringSrcSpans cstream0 cstream1)

2729 || not (matchIgnoringSrcSpans ps0 ps1)

2830

src/Ormolu/Exception.hs+1−6

@@ -10,10 +10,10 @@ where

1010

1111import Control.Exception

1212import Data.Text (Text)

13+import Ormolu.Utils (showOutputable)

1314import System.Exit (ExitCode (..), exitWith)

1415import System.IO

1516import qualified GHC

16−import qualified Outputable as GHC

1717

1818-- | Ormolu exception representing all cases when Ormolu can fail.

1919

@@ -72,8 +72,3 @@ showParsingErr msg spn err = unlines

7272 , showOutputable spn

7373 , err

7474 ]

75−

76−-- | Display something 'GHC.Outputable'.

77−

78−showOutputable :: GHC.Outputable o => o -> String

79−showOutputable = GHC.showSDocUnsafe . GHC.ppr

src/Ormolu/Parser.hs+13−10

@@ -15,10 +15,11 @@ import Data.Maybe (catMaybes)

1515import GHC hiding (IE, parseModule, parser)

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

1717import GHC.Paths (libdir)

18−import Ormolu.Anns

19−import Ormolu.CommentStream

2018import Ormolu.Config

2119import Ormolu.Exception

20+import Ormolu.Parser.Anns

21+import Ormolu.Parser.CommentStream

22+import Ormolu.Parser.Result

2223import qualified CmdLineParser as GHC

2324import qualified DynFlags as GHC

2425import qualified FastString as GHC

@@ -37,8 +38,7 @@ parseModule

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

3839 -> String -- ^ Input for parser

3940 -> m ( [GHC.Warn]

40− , Either (SrcSpan, String)

41− (CommentStream, Anns, ParsedSource)

41+ , Either (SrcSpan, String) ParseResult

4242 )

4343parseModule dynOpts path input' = liftIO $ do

4444 let (input, extraComments) = stripLinePragmas input'

@@ -56,10 +56,13 @@ parseModule dynOpts path input' = liftIO $ do

5656 GHC.PFailed _ ss m ->

5757 Left (ss, GHC.showSDoc dynFlags m)

5858 GHC.POk pstate pmod ->

59− Right ( mkCommentStream extraComments pstate

60− , mkAnns pstate

61− , pmod

62− )

59+ let (comments, exts) = mkCommentStream extraComments pstate

60+ in Right ParseResult

61+ { prParsedSource = pmod

62+ , prAnns = mkAnns pstate

63+ , prCommentStream = comments

64+ , prExtensions = exts

65+ }

6366 return (ws, r)

6467

6568----------------------------------------------------------------------------

@@ -85,8 +88,8 @@ initDynFlagsPure fp input = do

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

8689 -- to use it.

8790 dflags0 <- GHC.getSessionDynFlags

88− let pragmaInfo = GHC.getOptions dflags0 (GHC.stringToStringBuffer input) fp

89− (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 pragmaInfo

91+ let tokens = GHC.getOptions dflags0 (GHC.stringToStringBuffer input) fp

92+ (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 tokens

9093 -- Turn this on last to avoid T10942

9194 let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream

9295 -- Prevent parsing of .ghc.environment.* "package environment files"

src/Ormolu/Anns.hs → src/Ormolu/Parser/Anns.hsrenamed+1−1

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

11-- | Ormolu-specific representation of GHC annotations.

3−module Ormolu.Anns

3+module Ormolu.Parser.Anns

44 ( Anns (..)

55 , emptyAnns

66 , mkAnns

src/Ormolu/CommentStream.hs → src/Ormolu/Parser/CommentStream.hsrenamed+49−15

@@ -1,24 +1,32 @@

1+{-# LANGUAGE BangPatterns #-}

12{-# LANGUAGE DeriveDataTypeable #-}

23{-# LANGUAGE GeneralizedNewtypeDeriving #-}

34{-# LANGUAGE LambdaCase #-}

5+{-# LANGUAGE TupleSections #-}

57-- | Functions for working with comment stream.

7−module Ormolu.CommentStream

9+module Ormolu.Parser.CommentStream

810 ( CommentStream (..)

911 , Comment (..)

1012 , mkCommentStream

1113 , isPrevHaddock

14+ , showCommentStream

1215 )

1316where

1417

1518import Data.Char (isSpace)

1619import Data.Data (Data)

20+import Data.Either (partitionEithers)

1721import Data.List (isPrefixOf, sortOn)

1822import Data.List.NonEmpty (NonEmpty (..))

1923import Data.Maybe (mapMaybe)

24+import Data.Set (Set)

25+import Ormolu.Parser.LanguagePragma

26+import Ormolu.Utils (showOutputable)

2027import SrcLoc

2128import qualified Data.List.NonEmpty as NE

29+import qualified Data.Set as S

2230import qualified GHC

2331import qualified Lexer as GHC

2432

@@ -34,28 +42,31 @@ newtype CommentStream = CommentStream [RealLocated Comment]

3442newtype Comment = Comment (NonEmpty String)

3543 deriving (Eq, Show, Data)

3644

37−-- | Create 'CommentStream' from 'GHC.PState'.

45+-- | Create 'CommentStream' from 'GHC.PState'. We also create a 'Set' of

46+-- extensions here, which is not sorted in any way. The pragma comment are

47+-- removed from the 'CommentStream'.

3848

3949mkCommentStream

4050 :: [Located String] -- ^ Extra comments to include

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

42− -> CommentStream

43−mkCommentStream extraComments pstate

44− = CommentStream

45− -- NOTE It's easier to normalize pragmas right when we construct comment

46− -- streams. Because this way we need to do it only once and when we

47− -- perform checking later they'll automatically match.

48− . fmap (mkComment . (fmap normalizePragma))

49− . sortOn startOfSpan

50− . mapMaybe toRealSpan $

52+ -> (CommentStream, Set String)

53+ -- ^ Comment stream and a set of extensions enabled

54+mkCommentStream extraComments pstate =

55+ ( CommentStream $

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

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

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

59+ mkComment . fmap normalizePragma

60+ <$> sortOn (realSrcSpanStart . getLoc) comments

61+ , S.unions exts

62+ )

63+ where

64+ (comments, exts) = partitionEithers (partitionComments <$> rawComments)

65+ rawComments = mapMaybe toRealSpan $

5166 extraComments ++

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

5368 concatMap (fmap (fmap unAnnotationComment) . snd)

5469 (GHC.annotations_comments pstate)

55− where

56− startOfSpan (L l _) = realSrcSpanStart l

57− toRealSpan (L (RealSrcSpan l) a) = Just (L l a)

58− toRealSpan _ = Nothing

5970

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

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

@@ -63,6 +74,14 @@ mkCommentStream extraComments pstate

6374isPrevHaddock :: Comment -> Bool

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

6576

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

78+

79+showCommentStream :: CommentStream -> String

80+showCommentStream (CommentStream xs) = unlines $

81+ showComment <$> xs

82+ where

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

84+

6685----------------------------------------------------------------------------

6786-- Helpers

6887

@@ -105,3 +124,18 @@ unAnnotationComment = \case

105124 GHC.AnnDocOptions s -> s

106125 GHC.AnnLineComment s -> s

107126 GHC.AnnBlockComment s -> s

127+

128+toRealSpan :: Located a -> Maybe (RealLocated a)

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

130+toRealSpan _ = Nothing

131+

132+-- | If a given comment is a LANGUAGE pragma, return the set of extensions

133+-- it enables in 'Right'. Otherwise return the original comment unchanged.

134+

135+partitionComments

136+ :: RealLocated String

137+ -> Either (RealLocated String) (Set String)

138+partitionComments input =

139+ case parseLanguagePragma (unLoc input) of

140+ Nothing -> Left input

141+ Just exts -> Right exts

src/Ormolu/Parser/LanguagePragma.hsnew file+85

@@ -0,0 +1,85 @@

1+-- | A module for parsing of language pragmas from comments.

3+{-# LANGUAGE LambdaCase #-}

4+{-# LANGUAGE OverloadedStrings #-}

6+module Ormolu.Parser.LanguagePragma

7+ ( parseLanguagePragma

8+ )

9+where

10+

11+import Data.Char (toLower)

12+import Data.List (isPrefixOf)

13+import Data.Set (Set)

14+import FastString (mkFastString, unpackFS)

15+import Module (newSimpleUnitId, ComponentId (..))

16+import SrcLoc

17+import StringBuffer

18+import qualified Data.Set as S

19+import qualified EnumSet as ES

20+import qualified Lexer as L

21+

22+-- | Extract a 'Set' of language extensions from a comment if it's a

23+-- language pragma or return 'Nothing' otherwise.

24+

25+parseLanguagePragma

26+ :: String -- ^ Comment to try to parse

27+ -> Maybe (Set String)

28+parseLanguagePragma input =

29+ if "{-#" `isPrefixOf` input

30+ then do

31+ toks0 <- tokenize (drop 3 input)

32+ toks1 <- dropLanguage toks0

33+ S.fromList <$> parseExtensions toks1

34+ else Nothing

35+

36+-- | Assuming the input consists of a series of tokens from a language

37+-- pragma, return the set of enabled extensions.

38+

39+parseExtensions :: [L.Token] -> Maybe [String]

40+parseExtensions = \case

41+ (L.ITconid ext : L.ITclose_prag : []) -> return [unpackFS ext]

42+ (L.ITconid ext : L.ITcomma : xs) -> (unpackFS ext :) <$> parseExtensions xs

43+ _ -> Nothing

44+

45+-- | Drop LANGUAGE pragma text from the token stream.

46+

47+dropLanguage :: [L.Token] -> Maybe [L.Token]

48+dropLanguage = \case

49+ (L.ITconid lang : xs) -> go lang xs

50+ (L.ITvarid lang : xs) -> go lang xs

51+ _ -> Nothing

52+ where

53+ go lang xs =

54+ if (toLower <$> unpackFS lang) == "language"

55+ then Just xs

56+ else Nothing

57+

58+-- | Tokenize a given input using GHC's lexer.

59+

60+tokenize :: String -> Maybe [L.Token]

61+tokenize input =

62+ case L.unP pLexer parseState of

63+ L.PFailed {} -> Nothing

64+ L.POk _ x -> Just x

65+ where

66+ location = mkRealSrcLoc (mkFastString "") 1 1

67+ buffer = stringToStringBuffer input

68+ parseState = L.mkPStatePure parserFlags buffer location

69+ parserFlags = L.ParserFlags

70+ { L.pWarningFlags = ES.empty

71+ , L.pExtensionFlags = ES.empty

72+ , L.pThisPackage = newSimpleUnitId (ComponentId (mkFastString ""))

73+ , L.pExtsBitmap = 0xffffffffffffffff

74+ }

75+

76+-- | Haskell lexer.

77+

78+pLexer :: L.P [L.Token]

79+pLexer = go

80+ where

81+ go = do

82+ r <- L.lexer False return

83+ case unLoc r of

84+ L.ITeof -> return []

85+ x -> (x:) <$> go

src/Ormolu/Parser/Result.hsnew file+37

@@ -0,0 +1,37 @@

1+-- | A type for result of parsing.

3+{-# LANGUAGE RecordWildCards #-}

5+module Ormolu.Parser.Result

6+ ( ParseResult (..)

7+ , prettyPrintParseResult

8+ )

9+where

10+

11+import Data.Set (Set)

12+import GHC

13+import Ormolu.Parser.Anns

14+import Ormolu.Parser.CommentStream

15+

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

17+

18+data ParseResult = ParseResult

19+ { prParsedSource :: ParsedSource

20+ -- ^ 'ParsedSource' from GHC

21+ , prAnns :: Anns

22+ -- ^ Ormolu-specfic representation of annotations

23+ , prCommentStream :: CommentStream

24+ -- ^ Comment stream

25+ , prExtensions :: Set String

26+ -- ^ Extensions enabled in that module

27+ }

28+

29+-- | Pretty-print a 'ParseResult'.

30+

31+prettyPrintParseResult :: ParseResult -> String

32+prettyPrintParseResult ParseResult {..} = unlines

33+ [ "parse result:"

34+ , " comment stream:"

35+ , showCommentStream prCommentStream

36+ -- XXX extend as needed

37+ ]

src/Ormolu/Printer.hs+9−9

@@ -10,20 +10,20 @@ module Ormolu.Printer

1010where

1111

1212import Data.Text (Text)

13−import GHC

14−import Ormolu.Anns

15−import Ormolu.CommentStream

13+import Ormolu.Parser.Result

1614import Ormolu.Printer.Combinators

1715import Ormolu.Printer.Meat.Module

18−import Ormolu.SpanStream

16+import Ormolu.Printer.SpanStream

1917

2018-- | Render a module.

2119

2220printModule

2321 :: Bool -- ^ Whether to trace debugging information

24− -> CommentStream -- ^ Comment stream

25− -> Anns -- ^ Annotations

26− -> ParsedSource -- ^ Parsed source

22+ -> ParseResult -- ^ Result of parsing

2723 -> Text -- ^ Resulting rendition

28−printModule debugOn cstream anns src =

29− runR debugOn (p_hsModule src) (mkSpanStream src) cstream anns

24+printModule debugOn ParseResult {..} =

25+ runR debugOn

26+ (p_hsModule prExtensions prParsedSource)

27+ (mkSpanStream prParsedSource)

28+ prCommentStream

29+ prAnns

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

@@ -15,7 +15,7 @@ where

1515import Control.Monad

1616import Data.Coerce (coerce)

1717import Data.Data (Data)

18−import Ormolu.CommentStream

18+import Ormolu.Parser.CommentStream

1919import Ormolu.Printer.Internal

2020import Ormolu.Utils (isModule)

2121import SrcLoc

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

@@ -44,9 +44,9 @@ import Data.Text (Text)

4444import Data.Text.Lazy.Builder

4545import Debug.Trace

4646import GHC

47−import Ormolu.Anns

48−import Ormolu.CommentStream

49−import Ormolu.SpanStream

47+import Ormolu.Parser.Anns

48+import Ormolu.Parser.CommentStream

49+import Ormolu.Printer.SpanStream

5050import SrcLoc

5151import qualified Data.Text as T

5252import qualified Data.Text.Lazy as TL

src/Ormolu/Printer/Meat/LanguagePragma.hsnew file+23

@@ -0,0 +1,23 @@

1+-- | Pretty-printing of language pragmas.

3+{-# LANGUAGE LambdaCase #-}

4+{-# LANGUAGE OverloadedStrings #-}

6+module Ormolu.Printer.Meat.LanguagePragma

7+ ( p_langPragmas

8+ )

9+where

10+

11+import Data.Set (Set)

12+import Ormolu.Printer.Combinators

13+import qualified Data.Set as S

14+import qualified Data.Text as T

15+

16+p_langPragmas :: Set String -> R ()

17+p_langPragmas = mapM_ p_langPragma . S.toAscList

18+

19+p_langPragma :: String -> R ()

20+p_langPragma ext = line $ do

21+ txt "{-# LANGUAGE "

22+ txt (T.pack ext)

23+ txt " #-}"

src/Ormolu/Printer/Meat/Module.hs+15−5

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

1010

1111import Control.Monad

1212import Data.Maybe (isJust)

13+import Data.Set (Set)

1314import GHC

1415import Ormolu.Imports

1516import Ormolu.Printer.Combinators

@@ -18,10 +19,11 @@ import Ormolu.Printer.Meat.Common

1819import Ormolu.Printer.Meat.Declaration

1920import Ormolu.Printer.Meat.Declaration.Warning

2021import Ormolu.Printer.Meat.ImportExport

22+import Ormolu.Printer.Meat.LanguagePragma

2123import SrcLoc (combineSrcSpans)

2224

23−p_hsModule :: ParsedSource -> R ()

24−p_hsModule loc@(L moduleSpan hsModule) = do

25+p_hsModule :: Set String -> ParsedSource -> R ()

26+p_hsModule exts loc@(L moduleSpan hsModule) = do

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

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

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

@@ -30,6 +32,14 @@ p_hsModule loc@(L moduleSpan hsModule) = do

3032 Nothing -> moduleSpan

3133 Just (L exportsSpan _) -> combineSrcSpans moduleSpan exportsSpan

3234 locatedVia (Just spn) loc $ \HsModule {..} -> do

35+ let hasLangPragmas = not (null exts)

36+ hasModuleHeader = isJust hsmodName

37+ hasImports = not (null hsmodImports)

38+ hasDecls = not (null hsmodDecls)

39+ p_langPragmas exts

40+ when (hasLangPragmas &&

41+ (hasModuleHeader || hasImports || hasDecls)) $

42+ newline

3343 case hsmodName of

3444 Nothing -> pure ()

3545 Just hsmodName' -> line $ do

@@ -42,10 +52,10 @@ p_hsModule loc@(L moduleSpan hsModule) = do

4252 inci (locatedVia Nothing hsmodExports' p_hsmodExports)

4353 breakpoint

4454 txt "where"

45− when (not (null hsmodImports) || not (null hsmodDecls)) newline

55+ when (hasImports || hasDecls) newline

4656 forM_ (sortImports hsmodImports) (located' p_hsmodImport)

47− when (not (null hsmodImports) && not (null hsmodDecls)) newline

57+ when (hasImports && hasDecls) newline

4858 p_hsDecls Free hsmodDecls

4959 trailingComments <- hasMoreComments

50− when (trailingComments && isJust hsmodName) newline

60+ when (trailingComments && hasModuleHeader) newline

5161 spitRemainingComments

src/Ormolu/SpanStream.hs → src/Ormolu/Printer/SpanStream.hsrenamed+1−1

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

44-- | Build span stream from AST.

6−module Ormolu.SpanStream

6+module Ormolu.Printer.SpanStream

77 ( SpanStream (..)

88 , mkSpanStream

99 )

src/Ormolu/Utils.hs+7

@@ -4,12 +4,14 @@ module Ormolu.Utils

44 ( combineSrcSpans'

55 , isModule

66 , notImplemented

7+ , showOutputable

78 )

89where

910

1011import Data.Data (Data, showConstr, toConstr)

1112import Data.List.NonEmpty (NonEmpty (..))

1213import SrcLoc

14+import qualified Outputable as GHC

1315

1416-- | Combine all source spans from the given list.

1517

@@ -25,3 +27,8 @@ isModule x = showConstr (toConstr x) == "HsModule"

2527

2628notImplemented :: String -> a

2729notImplemented msg = error $ "not implemented yet: " ++ msg

30+

31+-- | Pretty-print an 'GHC.Outputable' thing.

32+

33+showOutputable :: GHC.Outputable o => o -> String

34+showOutputable = GHC.showSDocUnsafe . GHC.ppr

tests/Ormolu/Parser/LanguagePragmaSpec.hsnew file+22

@@ -0,0 +1,22 @@

1+module Ormolu.Parser.LanguagePragmaSpec (spec) where

3+import Ormolu.Parser.LanguagePragma

4+import Test.Hspec

5+import qualified Data.Set as S

7+spec :: Spec

8+spec = do

9+ describe "parseLanguagePragma" $ do

10+ stdTest "{-# LANGUAGE Foo #-}" (Just ["Foo"])

11+ stdTest "{-# language Foo #-}" (Just ["Foo"])

12+ stdTest "{-# lAngUAGe Foo #-}" (Just ["Foo"])

13+ stdTest "{-# LANGUAGE Foo, Bar #-}" (Just ["Bar", "Foo"])

14+ stdTest "{-# LANGUAGE Foo Bar #-}" Nothing

15+ stdTest "{-# BOO Foo #-}" Nothing

16+ stdTest "something" Nothing

17+ stdTest "{-# LANGUAGE foo, Bar #-}" Nothing

18+

19+stdTest :: String -> Maybe [String] -> Spec

20+stdTest input result = it input $

21+ (S.toAscList <$> parseLanguagePragma input) `shouldBe`

22+ result

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

@@ -2,7 +2,7 @@

33module Ormolu.Printer.CombinatorsSpec (spec) where

5−import Ormolu.Anns

5+import Ormolu.Parser.Anns

66import Ormolu.Printer.Combinators

77import Ormolu.Printer.Internal

88import Test.Hspec