9a0276b · ormolu · git.iko.soy

data/examples/declaration/value/function/infix-out.hsnew file+1

compare with master

unifiedsplit

@@ -0,0 +1 @@

1+foo x y = x `bar` y

data/examples/declaration/value/function/infix.hsnew file+1

@@ -0,0 +1 @@

1+foo x y = x `bar` y

data/examples/declaration/value/function/pattern-bind-out.hsnew file+6

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

1+foo :: Int

2+foo = bar

3+ where

4+ Foo bar baz = quux

5+ Baz

6+ quux = zoo

data/examples/declaration/value/function/pattern-bind.hsnew file+6

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

1+foo :: Int

2+foo = bar

3+ where

4+ Foo bar baz = quux

5+ Baz

6+ quux = zoo

data/examples/declaration/value/function/prefix-out.hsnew file+1

@@ -0,0 +1 @@

1+foo x y = (+) x y

data/examples/declaration/value/function/prefix.hsnew file+1

@@ -0,0 +1 @@

1+foo x y = (+) x y

data/examples/declaration/value/pattern-synonyms/bidirectional-out.hsnew file+6

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

1+pattern Arrow t1 t2 = App "->" [t1, t2]

2+pattern Int = App "Int" []

3+pattern Maybe t =

4+ App

5+ "Maybe"

6+ [t]

data/examples/declaration/value/pattern-synonyms/bidirectional.hsnew file+7

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

1+pattern Arrow t1 t2 = App "->" [t1, t2]

2+pattern Int =

3+ App "Int" []

4+pattern Maybe t =

5+ App

6+ "Maybe"

7+ [t]

data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional-out.hsnew file+10

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

1+{-# LANGUAGE PatternSynonyms #-}

2+pattern HeadC x <-

3+ x : xs

4+ where

5+ HeadC x = [x]

6+

7+pattern HeadC' x <-

8+ x : xs

9+ where

10+ HeadC' x = [x]

data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional.hsnew file+9

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

1+{-# LANGUAGE PatternSynonyms #-}

2+

3+pattern HeadC x <- x:xs where

4+ HeadC x = [x]

5+

6+pattern HeadC' x <-

7+ x:xs

8+ where

9+ HeadC' x = [x]

data/examples/declaration/value/pattern-synonyms/unidirectional-out.hsnew file+5

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

1+{-# LANGUAGE PatternSynonyms #-}

2+pattern Head x <- x : xs

3+

4+pattern Head' x <-

5+ x : xs

data/examples/declaration/value/pattern-synonyms/unidirectional.hsnew file+6

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

1+{-# LANGUAGE PatternSynonyms #-}

2+

3+pattern Head x <- x:xs

4+

5+pattern Head' x

6+ <- x:xs

ormolu.cabal+1

@@ -47,6 +47,7 @@ library

47 , text >= 0.2 && < 1.3

48 , yaml >= 0.8 && < 0.12

49 exposed-modules: Ormolu

50+ , Ormolu.Anns

50 , Ormolu.CommentStream

51 , Ormolu.CommentStream

51 , Ormolu.Config

52 , Ormolu.Config

52 , Ormolu.Diff

53 , Ormolu.Diff

src/Ormolu.hs+5−4

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

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

19import Data.Text (Text)

20import Debug.Trace

21+import Ormolu.Anns

21import Ormolu.CommentStream

22import Ormolu.CommentStream

22import Ormolu.Config

23import Ormolu.Config

23import Ormolu.Diff

24import Ormolu.Diff

@@ -47,18 +48,18 @@ ormolu

47 -> String -- ^ Input to format

48 -> String -- ^ Input to format

48 -> m Text

49 -> m Text

49ormolu cfg path str = do

50ormolu cfg path str = do

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

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

51 parseModule' cfg OrmoluParsingFailed path str

52 parseModule' cfg OrmoluParsingFailed path str

52 when (cfgDebug cfg) $ do

53 when (cfgDebug cfg) $ do

53 traceM "warnings:\n"

54 traceM "warnings:\n"

54 traceM (concatMap showWarn ws)

55 traceM (concatMap showWarn ws)

55 traceM "comment stream:\n"

56 traceM "comment stream:\n"

56 traceM (showCommentStream cstream0)

57 traceM (showCommentStream cstream0)

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

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

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

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

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

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

60 unless (cfgUnsafe cfg) $ do

61 unless (cfgUnsafe cfg) $ do

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

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

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

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

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

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

64 liftIO $ throwIO (OrmoluASTDiffers str txt)

65 liftIO $ throwIO (OrmoluASTDiffers str txt)

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

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

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

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

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

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

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

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

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

94 -- ^ Comment stream and parsed source

95 -- ^ Comment stream and parsed source

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

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

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

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

src/Ormolu/Anns.hsnew file+48

@@ -0,0 +1,48 @@

1+-- | Ormolu-specfiic representation of GHC annotations.

2+

3+module Ormolu.Anns

4+ ( Anns (..)

5+ , emptyAnns

6+ , mkAnns

7+ , lookupAnns

8+ )

9+where

10+

11+import Data.Map.Strict (Map)

12+import Data.Maybe (mapMaybe)

13+import SrcLoc

14+import qualified Data.Map.Strict as M

15+import qualified GHC

16+import qualified Lexer as GHC

17+

18+-- | Ormolu-specific representation of GHC annotations.

19+

20+newtype Anns = Anns (Map RealSrcSpan [GHC.AnnKeywordId])

21+ deriving (Eq)

22+

23+-- | Empty 'Anns'.

24+

25+emptyAnns :: Anns

26+emptyAnns = Anns M.empty

27+

28+-- | Create 'Anns' from 'GHC.PState'.

29+

30+mkAnns

31+ :: GHC.PState

32+ -> Anns

33+mkAnns pstate = Anns $

34+ M.fromListWith (++) (mapMaybe f (GHC.annotations pstate))

35+ where

36+ f ((spn, kid), _) =

37+ case spn of

38+ RealSrcSpan rspn -> Just (rspn, [kid])

39+ UnhelpfulSpan _ -> Nothing

40+

41+-- | Lookup 'GHC.AnnKeywordId's corresponding to a given 'SrcSpan'.

42+

43+lookupAnns

44+ :: SrcSpan -- ^ Span to lookup with

45+ -> Anns -- ^ Collection of annotations

46+ -> [GHC.AnnKeywordId]

47+lookupAnns (RealSrcSpan rspn) (Anns m) = M.findWithDefault [] rspn m

48+lookupAnns (UnhelpfulSpan _) _ = []

src/Ormolu/Parser.hs+12−3

@@ -15,6 +15,7 @@ import Data.Maybe (catMaybes)

15import GHC hiding (IE, parseModule, parser)

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

17import GHC.Paths (libdir)

18+import Ormolu.Anns

18import Ormolu.CommentStream

19import Ormolu.CommentStream

19import Ormolu.Config

20import Ormolu.Config

20import Ormolu.Exception

21import Ormolu.Exception

@@ -35,7 +36,10 @@ parseModule

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

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

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

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

37 -> String -- ^ Input for parser

38 -> String -- ^ Input for parser

39+ -> m ( [GHC.Warn]

40+ , Either (SrcSpan, String)

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

41+ (CommentStream, Anns, ParsedSource)

42+ )

39parseModule dynOpts path input' = liftIO $ do

43parseModule dynOpts path input' = liftIO $ do

40 let (input, extraComments) = stripLinePragmas input'

44 let (input, extraComments) = stripLinePragmas input'

41 (ws, dynFlags) <- ghcWrapper $ do

45 (ws, dynFlags) <- ghcWrapper $ do

@@ -49,8 +53,13 @@ parseModule dynOpts path input' = liftIO $ do

49 when (GHC.xopt Cpp dynFlags) $

53 when (GHC.xopt Cpp dynFlags) $

50 throwIO OrmoluCppEnabled

54 throwIO OrmoluCppEnabled

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

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

56+ GHC.PFailed _ ss m ->

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

57+ Left (ss, GHC.showSDoc dynFlags m)

58+ GHC.POk pstate pmod ->

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

59+ Right ( mkCommentStream extraComments pstate

60+ , mkAnns pstate

61+ , pmod

62+ )

54 return (ws, r)

63 return (ws, r)

55

64

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

65----------------------------------------------------------------------------

src/Ormolu/Printer.hs+4−2

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

11

12import Data.Text (Text)

13import GHC

14+import Ormolu.Anns

14import Ormolu.CommentStream

15import Ormolu.CommentStream

15import Ormolu.Printer.Combinators

16import Ormolu.Printer.Combinators

16import Ormolu.Printer.Meat.Module

17import Ormolu.Printer.Meat.Module

@@ -21,7 +22,8 @@ import Ormolu.SpanStream

21printModule

22printModule

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

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

23 -> CommentStream -- ^ Comment stream

24 -> CommentStream -- ^ Comment stream

25+ -> Anns -- ^ Annotations

24 -> ParsedSource -- ^ Parsed source

26 -> ParsedSource -- ^ Parsed source

25 -> Text -- ^ Resulting rendition

27 -> Text -- ^ Resulting rendition

26−printModule debugOn cstream src =

28+printModule debugOn cstream anns src =

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

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

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

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

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2+{-# LANGUAGE LambdaCase #-}

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE RankNTypes #-}

4{-# LANGUAGE RankNTypes #-}

4

5

@@ -30,6 +31,8 @@ module Ormolu.Printer.Internal

30 , setIndent

31 , setIndent

31 , getEnclosingSpan

32 , getEnclosingSpan

32 , withEnclosingSpan

33 , withEnclosingSpan

34+ -- * Annotations

35+ , getAnns

33 )

36 )

34where

37where

35

38

@@ -41,6 +44,7 @@ import Data.Text (Text)

41import Data.Text.Lazy.Builder

44import Data.Text.Lazy.Builder

42import Debug.Trace

45import Debug.Trace

43import GHC

46import GHC

47+import Ormolu.Anns

44import Ormolu.CommentStream

48import Ormolu.CommentStream

45import Ormolu.SpanStream

49import Ormolu.SpanStream

46import SrcLoc

50import SrcLoc

@@ -70,6 +74,8 @@ data RC = RC

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

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

71 , rcEnclosingSpan :: Maybe RealSrcSpan

75 , rcEnclosingSpan :: Maybe RealSrcSpan

72 -- ^ Span of enclosing element of AST

76 -- ^ Span of enclosing element of AST

77+ , rcAnns :: Anns

78+ -- ^ Collection of annotations

73 }

79 }

74

80

75-- | State context of 'R'.

81-- | State context of 'R'.

@@ -101,8 +107,9 @@ runR

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

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

102 -> SpanStream -- ^ Span stream

108 -> SpanStream -- ^ Span stream

103 -> CommentStream -- ^ Comment stream

109 -> CommentStream -- ^ Comment stream

110+ -> Anns -- ^ Annotations

104 -> Text -- ^ Resulting rendition

111 -> Text -- ^ Resulting rendition

105−runR debug (R m) sstream cstream =

112+runR debug (R m) sstream cstream anns =

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

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

107 where

114 where

108 rc = RC

115 rc = RC

@@ -111,6 +118,7 @@ runR debug (R m) sstream cstream =

111 , rcRelaxedComments = False

118 , rcRelaxedComments = False

112 , rcDebug = debug

119 , rcDebug = debug

113 , rcEnclosingSpan = Nothing

120 , rcEnclosingSpan = Nothing

121+ , rcAnns = anns

114 }

122 }

115 sc = SC

123 sc = SC

116 { scColumn = 0

124 { scColumn = 0

@@ -322,6 +330,16 @@ withEnclosingSpan spn (R m) = do

322 }

330 }

323 R (local modRC m)

331 R (local modRC m)

324

332

333+----------------------------------------------------------------------------

334+-- Annotations

335+

336+-- | For a given span return 'AnnKeywordId's associated with it.

337+

338+getAnns

339+ :: SrcSpan

340+ -> R [AnnKeywordId]

341+getAnns spn = lookupAnns spn <$> R (asks rcAnns)

342+

325----------------------------------------------------------------------------

343----------------------------------------------------------------------------

326-- Debug helpers

344-- Debug helpers

327

345

src/Ormolu/Printer/Meat/Common.hs+26−25

@@ -7,20 +7,18 @@ module Ormolu.Printer.Meat.Common

7 ( p_hsmodName

8 , p_ieWrappedName

9 , p_rdrName

10− , p_rdrName'

11 , p_qualName

10 , p_qualName

12 , p_ieWildcard

11 , p_ieWildcard

13− , opParens

14 )

12 )

15where

13where

16

14

17−import Data.Char (isAlphaNum)

18import GHC hiding (GhcPs, IE)

15import GHC hiding (GhcPs, IE)

19import Module (Module (..))

16import Module (Module (..))

20import OccName (OccName (..))

17import OccName (OccName (..))

21import Ormolu.Printer.Combinators

18import Ormolu.Printer.Combinators

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

19+import Ormolu.Printer.Internal (getAnns)

20+import Ormolu.Utils (getSpan)

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

21+import RdrName (RdrName (..))

24

22

25p_hsmodName :: ModuleName -> R ()

23p_hsmodName :: ModuleName -> R ()

26p_hsmodName mname = do

24p_hsmodName mname = do

@@ -29,23 +27,35 @@ p_hsmodName mname = do

29

27

30p_ieWrappedName :: IEWrappedName RdrName -> R ()

28p_ieWrappedName :: IEWrappedName RdrName -> R ()

31p_ieWrappedName = \case

29p_ieWrappedName = \case

32− IEName l2 -> located l2 p_rdrName

30+ IEName x -> p_rdrName x

33− IEPattern l2 -> located l2 $ \x -> do

31+ IEPattern x -> do

34 txt "pattern "

32 txt "pattern "

35 p_rdrName x

33 p_rdrName x

36− IEType l2 -> located l2 $ \x -> do

34+ IEType x -> do

37 txt "type "

35 txt "type "

38 p_rdrName x

36 p_rdrName x

39

37

40−p_rdrName :: RdrName -> R ()

38+-- | Render a @'Located' 'RdrName'@.

41−p_rdrName x = opParens (rdrNameOcc x) (p_rdrName' x)

42

39

43−p_rdrName' :: RdrName -> R ()

40+p_rdrName :: Located RdrName -> R ()

41+p_rdrName l = located l $ \x -> do

42+ ids <- getAnns (getSpan l)

43+ -- NOTE Right now we're mainly interested in backticks and parentheses.

44+ let backticksWrapper =

45+ if AnnBackquote `elem` ids

46+ then backticks

47+ else id

48+ parensWrapper =

49+ if AnnOpenP `elem` ids

50+ then parens

51+ else id

52+ -- TODO Check if it's possible to detect simple quoting here as well.

53+ parensWrapper . backticksWrapper $

44−p_rdrName' x = case x of

54+ case x of

45− Unqual occName -> atom occName

55+ Unqual occName -> atom occName

46− Qual mname occName -> p_qualName mname occName

56+ Qual mname occName -> p_qualName mname occName

47− Orig (Module _ mname) occName -> p_qualName mname occName

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

48− Exact name -> atom name

58+ Exact name -> atom name

49

59

50p_qualName :: ModuleName -> OccName -> R ()

60p_qualName :: ModuleName -> OccName -> R ()

51p_qualName mname occName = do

61p_qualName mname occName = do

@@ -57,12 +67,3 @@ p_ieWildcard :: IEWildcard -> R ()

57p_ieWildcard = \case

67p_ieWildcard = \case

58 NoIEWildcard -> return ()

68 NoIEWildcard -> return ()

59 IEWildcard n -> parens (atom n)

69 IEWildcard n -> parens (atom n)

60−

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

62−-- consists only of punctuation characters.

63−

64−opParens :: Outputable a => a -> R () -> R ()

65−opParens x m =

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

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

68− else m

src/Ormolu/Printer/Meat/Declaration/Data.hs+7−7

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

30 txt $ case dd_ND of

31 NewType -> "newtype "

32 DataType -> "data "

33− located name p_rdrName'

33+ p_rdrName name

34 unless (null hsq_explicit) space

35 spaceSep (located' p_hsTyVarBndr) hsq_explicit

36 case dd_kindSig of

@@ -59,7 +59,7 @@ p_dataDecl _ _ (XHsDataDefn NoExt) = notImplemented "XHsDataDefn"

59p_conDecl :: ConDecl GhcPs -> R ()

60p_conDecl = \case

61 ConDeclGADT {..} -> do

62− spaceSep (located' p_rdrName) con_names

62+ spaceSep p_rdrName con_names

63 breakpoint

64 inci $ do

65 txt ":: "

@@ -83,20 +83,20 @@ p_conDecl = \case

83 forM_ con_mb_cxt p_lhsContext

84 case con_args of

85 PrefixCon xs -> do

86− located con_name p_rdrName

86+ p_rdrName con_name

87 unless (null xs) breakpoint

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

89 RecCon l -> do

90− located con_name p_rdrName

90+ p_rdrName con_name

91 breakpoint

92 inci $ located l p_conDeclFields

93 InfixCon x y -> do

94 located x p_hsType

95 breakpoint

96 inci $ do

97− backticks (located con_name p_rdrName)

97+ p_rdrName con_name

98− breakpoint

98+ space

99− inci (located y p_hsType)

99+ located y p_hsType

100 XConDecl NoExt -> notImplemented "XConDecl"

101

102p_forallBndrs

src/Ormolu/Printer/Meat/Declaration/Pat.hs+13−10

@@ -17,12 +17,12 @@ import Ormolu.Utils

17p_pat :: Pat GhcPs -> R ()

18p_pat = \case

19 WildPat NoExt -> txt "_"

20− VarPat NoExt name -> located name p_rdrName

20+ VarPat NoExt name -> p_rdrName name

21 LazyPat NoExt pat -> do

22 txt "~"

23 located pat p_pat

24 AsPat NoExt name pat -> do

25− located name p_rdrName

25+ p_rdrName name

26 txt "@"

27 located pat p_pat

28 ParPat NoExt pat ->

@@ -43,21 +43,24 @@ p_pat = \case

43 located pat p_pat

44 ConPatIn pat details ->

45 case details of

46− PrefixCon xs -> do

46+ PrefixCon xs -> sitcc $ do

47− located pat p_rdrName

47+ p_rdrName pat

48− unless (null xs) . inci . inci $ do

48+ unless (null xs) $ do

49 breakpoint

50− velt' (located' p_pat <$> xs)

50+ inci $ velt' (located' p_pat <$> xs)

51 RecCon (HsRecFields fields dotdot) -> do

52− located pat p_rdrName

52+ p_rdrName pat

53 case dotdot of

54 Nothing -> txt " {..}"

55 Just _ -> do

56 braces $ velt (withSep comma (located' p_hsRecField) fields)

57 InfixCon x y -> do

58 located x p_pat

59+ breakpoint

60+ inci $ do

59− located pat (backticks . p_rdrName)

61+ p_rdrName pat

62+ space

60− located y p_pat

63+ located y p_pat

61 ConPatOut {} -> notImplemented "ConPatOut"

64 ConPatOut {} -> notImplemented "ConPatOut"

62 ViewPat {} -> notImplemented "ViewPat"

65 ViewPat {} -> notImplemented "ViewPat"

63 SplicePat {} -> notImplemented "SplicePat"

66 SplicePat {} -> notImplemented "SplicePat"

@@ -71,4 +74,4 @@ p_pat = \case

71p_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R ()

74p_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R ()

72p_hsRecField HsRecField {..} =

75p_hsRecField HsRecField {..} =

73 located hsRecFieldLbl $ \x ->

76 located hsRecFieldLbl $ \x ->

74− located (rdrNameFieldOcc x) p_rdrName

77+ p_rdrName (rdrNameFieldOcc x)

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

@@ -29,7 +29,7 @@ p_typeSig

29 -> LHsSigWcType GhcPs

30 -> R ()

31p_typeSig names HsWC {..} = do

32− spaceSep (located' p_rdrName) names

32+ spaceSep p_rdrName names

33 breakpoint

34 inci $ do

35 txt ":: "

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

@@ -23,7 +23,7 @@ p_synDecl

23 -> R ()

24p_synDecl name tvars t = line $ do

25 txt "type "

26− located name p_rdrName'

26+ p_rdrName name

27 let HsQTvs {..} = tvars

28 unless (null hsq_explicit) space

29 spaceSep (located' p_hsTyVarBndr) hsq_explicit

src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs+4−4

@@ -24,7 +24,7 @@ p_famDecl FamilyDecl {..} = do

24 DataFamily -> Nothing <$ txt "data family "

25 OpenTypeFamily -> Nothing <$ txt "type family "

26 ClosedTypeFamily eqs -> Just eqs <$ txt "type family "

27− located fdLName p_rdrName

27+ p_rdrName fdLName

28 space

29 let HsQTvs {..} = fdTyVars

30 items =

@@ -65,15 +65,15 @@ p_familyResultSigL injAnn l =

65p_injectivityAnn :: InjectivityAnn GhcPs -> R ()

66p_injectivityAnn (InjectivityAnn a bs) = do

67 txt "| "

68− located a p_rdrName

68+ p_rdrName a

69 space

70 txt "-> "

71− spaceSep (located' p_rdrName) bs

71+ spaceSep p_rdrName bs

72

73p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R ()

74p_tyFamInstEqn HsIB {..} = do

75 let FamEqn {..} = hsib_body

76− located feqn_tycon p_rdrName

76+ p_rdrName feqn_tycon

77 space

78 spaceSep (located' p_hsType) feqn_pats

79 txt " ="

src/Ormolu/Printer/Meat/Declaration/Value.hs+62−13

@@ -26,17 +26,22 @@ p_valDecl = line . p_valDecl'

26p_valDecl' :: HsBindLR GhcPs GhcPs -> R ()

27p_valDecl' = \case

28 FunBind NoExt funId funMatches _ _ -> p_funBind funId funMatches

29− _ -> notImplemented "certain kinds of binding declarations"

29+ PatBind NoExt pat grhss _ -> p_match PatternBind [pat] grhss

30+ VarBind {} -> error "VarBinds are introduced by the type checker"

31+ AbsBinds {} -> error "AbsBinds are introduced by the type checker"

32+ PatSynBind NoExt psb -> p_patSynBind psb

33+ XHsBindsLR NoExt -> notImplemented "XHsBindsLR"

30

34

31p_funBind

35p_funBind

32− :: Located RdrName -- ^

36+ :: Located RdrName

33− -> MatchGroup GhcPs (LHsExpr GhcPs) -- ^

37+ -> MatchGroup GhcPs (LHsExpr GhcPs)

34 -> R ()

38 -> R ()

35p_funBind name mgroup =

39p_funBind name mgroup =

36− p_matchGroup (Function (unL name)) mgroup

40+ p_matchGroup (Function name) mgroup

37

41

38data MatchGroupStyle

42data MatchGroupStyle

39− = Function RdrName

43+ = Function (Located RdrName)

44+ | PatternBind

40 | Case

45 | Case

41 | Lambda

46 | Lambda

42 | LambdaCase

47 | LambdaCase

@@ -47,14 +52,15 @@ p_matchGroup

47 -> R ()

52 -> R ()

48p_matchGroup style MG {..} =

53p_matchGroup style MG {..} =

49 locatedVia Nothing mg_alts $

54 locatedVia Nothing mg_alts $

50− newlineSep (located' (p_match style))

55+ newlineSep (located' (\Match {..} -> p_match style m_pats m_grhss))

51p_matchGroup _ (XMatchGroup NoExt) = notImplemented "XMatchGroup"

56p_matchGroup _ (XMatchGroup NoExt) = notImplemented "XMatchGroup"

52

57

53p_match

58p_match

54 :: MatchGroupStyle

59 :: MatchGroupStyle

60+ -> [LPat GhcPs]

55− -> Match GhcPs (LHsExpr GhcPs)

61+ -> GRHSs GhcPs (LHsExpr GhcPs)

56 -> R ()

62 -> R ()

57−p_match style Match {..} = do

63+p_match style m_pats m_grhss = do

58 case style of

64 case style of

59 Function name -> p_rdrName name

65 Function name -> p_rdrName name

60 _ -> return ()

66 _ -> return ()

@@ -76,10 +82,14 @@ p_match style Match {..} = do

76 switchLayout combinedSpans $ do

82 switchLayout combinedSpans $ do

77 case style of

83 case style of

78 Function _ -> breakpoint

84 Function _ -> breakpoint

85+ PatternBind -> return ()

79 Case -> return ()

86 Case -> return ()

80 Lambda -> txt "\\"

87 Lambda -> txt "\\"

81 LambdaCase -> return ()

88 LambdaCase -> return ()

89+ let wrapper = case style of

90+ Function _ -> inci'

91+ _ -> id

82− inci' (velt' (located' p_pat <$> m_pats))

92+ wrapper (velt' (located' p_pat <$> m_pats))

83 return inci'

93 return inci'

84 inci' $ do

94 inci' $ do

85 let GRHSs {..} = m_grhss

95 let GRHSs {..} = m_grhss

@@ -87,6 +97,7 @@ p_match style Match {..} = do

87 space

97 space

88 txt $ case style of

98 txt $ case style of

89 Function _ -> "="

99 Function _ -> "="

100+ PatternBind -> "="

90 _ -> "->"

101 _ -> "->"

91 let combinedSpans = combineSrcSpans' $

102 let combinedSpans = combineSrcSpans' $

92 getGRHSSpan . unL <$> NE.fromList grhssGRHSs

103 getGRHSSpan . unL <$> NE.fromList grhssGRHSs

@@ -102,7 +113,6 @@ p_match style Match {..} = do

102 newline

113 newline

103 line (txt "where")

114 line (txt "where")

104 inci (located grhssLocalBinds p_hsLocalBinds)

115 inci (located grhssLocalBinds p_hsLocalBinds)

105−p_match _ (XMatch NoExt) = notImplemented "XMatchGroup"

106

116

107p_grhs :: GRHS GhcPs (LHsExpr GhcPs) -> R ()

117p_grhs :: GRHS GhcPs (LHsExpr GhcPs) -> R ()

108p_grhs (GRHS NoExt guards body) =

118p_grhs (GRHS NoExt guards body) =

@@ -148,13 +158,13 @@ p_hsLocalBinds = \case

148

158

149p_hsExpr :: HsExpr GhcPs -> R ()

159p_hsExpr :: HsExpr GhcPs -> R ()

150p_hsExpr = \case

160p_hsExpr = \case

151− HsVar NoExt name -> located name p_rdrName'

161+ HsVar NoExt name -> p_rdrName name

152 HsUnboundVar NoExt _ -> notImplemented "HsUnboundVar"

162 HsUnboundVar NoExt _ -> notImplemented "HsUnboundVar"

153 HsConLikeOut NoExt _ -> notImplemented "HsConLikeOut"

163 HsConLikeOut NoExt _ -> notImplemented "HsConLikeOut"

154 HsRecFld NoExt x ->

164 HsRecFld NoExt x ->

155 case x of

165 case x of

156− Unambiguous NoExt name -> located name p_rdrName'

166+ Unambiguous NoExt name -> p_rdrName name

157− Ambiguous NoExt name -> located name p_rdrName'

167+ Ambiguous NoExt name -> p_rdrName name

158 XAmbiguousFieldOcc NoExt -> notImplemented "XAmbiguousFieldOcc"

168 XAmbiguousFieldOcc NoExt -> notImplemented "XAmbiguousFieldOcc"

159 HsOverLabel NoExt _ _ -> notImplemented "HsOverLabel"

169 HsOverLabel NoExt _ _ -> notImplemented "HsOverLabel"

160 HsIPVar NoExt (HsIPName name) -> atom name

170 HsIPVar NoExt (HsIPName name) -> atom name

@@ -247,6 +257,45 @@ p_hsExpr = \case

247 HsWrap {} -> notImplemented "HsWrap"

257 HsWrap {} -> notImplemented "HsWrap"

248 XExpr {} -> notImplemented "XExpr"

258 XExpr {} -> notImplemented "XExpr"

249

259

260+p_patSynBind :: PatSynBind GhcPs GhcPs -> R ()

261+p_patSynBind PSB {..} = do

262+ txt "pattern "

263+ case psb_dir of

264+ Unidirectional -> do

265+ p_rdrName psb_id

266+ space

267+ p_patSynDetails psb_args

268+ txt " <-"

269+ breakpoint

270+ inci (located psb_def p_pat)

271+ ImplicitBidirectional -> do

272+ p_rdrName psb_id

273+ space

274+ p_patSynDetails psb_args

275+ txt " ="

276+ breakpoint

277+ located psb_def p_pat

278+ ExplicitBidirectional mgroup -> do

279+ p_rdrName psb_id

280+ space

281+ p_patSynDetails psb_args

282+ txt " <-"

283+ breakpoint

284+ inci (located psb_def p_pat)

285+ newline

286+ inci $ do

287+ line (txt "where")

288+ inci (p_matchGroup (Function psb_id) mgroup)

289+p_patSynBind (XPatSynBind NoExt) = notImplemented "XPatSynBind"

290+

291+p_patSynDetails :: HsPatSynDetails (Located RdrName) -> R ()

292+p_patSynDetails = \case

293+ PrefixCon xs ->

294+ velt' (p_rdrName <$> xs)

295+ RecCon xs ->

296+ velt' (p_rdrName . recordPatSynPatVar <$> xs)

297+ InfixCon _ _ -> notImplemented "InfixCon"

298+

250----------------------------------------------------------------------------

299----------------------------------------------------------------------------

251-- Helpers

300-- Helpers

252

301

src/Ormolu/Printer/Meat/Type.hs+5−5

@@ -33,7 +33,7 @@ p_hsType = \case

33 case p of

34 Promoted -> txt "'"

35 NotPromoted -> return ()

36− located n p_rdrName'

36+ p_rdrName n

37 HsAppTy NoExt f x -> sitcc $ do

38 located f p_hsType

39 breakpoint

@@ -61,7 +61,7 @@ p_hsType = \case

61 located x p_hsType

62 breakpoint

63 inci $ do

64− located op p_rdrName'

64+ p_rdrName op

65 space

66 located y p_hsType

67 HsParTy NoExt t ->

@@ -112,8 +112,8 @@ p_hsContext = \case

112

113p_hsTyVarBndr :: HsTyVarBndr GhcPs -> R ()

114p_hsTyVarBndr = \case

115− UserTyVar NoExt l ->

115+ UserTyVar NoExt x ->

116− located l p_rdrName

116+ p_rdrName x

117 KindedTyVar NoExt l k -> parens $ do

118 located l atom

119 breakpoint

@@ -130,7 +130,7 @@ p_conDeclField :: ConDeclField GhcPs -> R ()

130p_conDeclField ConDeclField {..} = do

131 sitcc . velt $ withSep

132 comma

133− (located' (located' p_rdrName . rdrNameFieldOcc))

133+ (located' (p_rdrName . rdrNameFieldOcc))

134 cd_fld_names

135 breakpoint

136 sitcc . inci $ do

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

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

2

3module Ormolu.Printer.CombinatorsSpec (spec) where

4

5+import Ormolu.Anns

5import Ormolu.Printer.Combinators

6import Ormolu.Printer.Combinators

6import Ormolu.Printer.Internal

7import Ormolu.Printer.Internal

7import Test.Hspec

8import Test.Hspec

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

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

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

97shouldRender m path = do

98shouldRender m path = do

98 expected <- T.readFile path

99 expected <- T.readFile path

99− runR False m mempty mempty `shouldBe` expected

100+ runR False m mempty mempty emptyAnns `shouldBe` expected

100

101

101-- | Render using single-line layout.

102-- | Render using single-line layout.

102

103