00b08ee · ormolu · git.iko.soy

git.iko.soy/ormolu

Implement rendering of data type declarations

commit00b08eeaffa7e50b72bbc57054f728ef340e6b67 authormrkkrp <mark.karpov@tweag.io> dateWed 10 Apr 2019, 23:30 (8 years ago) parente01287a

44 files changed+520−131

compare with master

unifiedsplit

data/examples/declaration/data/deriving-strategies-out.hsnew file+8

@@ -0,0 +1,8 @@

1+-- | Something.

2+newtype Foo = Foo Int

3+ deriving stock (Eq, Show, Generic)

4+ deriving anyclass

5+ ( ToJSON

6+ , FromJSON

7+ )

8+ deriving newtype (Num)

data/examples/declaration/data/deriving-strategies.hsnew file+9

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

1+-- | Something.

3+newtype Foo = Foo Int

4+ deriving stock (Eq, Show, Generic)

5+ deriving anyclass

6+ ( ToJSON

7+ , FromJSON

8+ )

9+ deriving newtype (Num)

data/examples/declaration/data/existential-multiline-out.hsnew file+4

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

1+{-# LANGUAGE ExistentialQuantification #-}

2+data Foo

3+ = forall a. MkFoo a (a -> Bool)

4+ | forall a. Eq a => MkBar a

data/examples/declaration/data/existential-multiline.hsnew file+5

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

1+{-# LANGUAGE ExistentialQuantification #-}

3+data Foo

4+ = forall a. MkFoo a (a -> Bool)

5+ | forall a. Eq a => MkBar a

data/examples/declaration/data/existential-out.hsnew file+2

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

1+{-# LANGUAGE ExistentialQuantification #-}

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

data/examples/declaration/data/existential.hsnew file+3

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

1+{-# LANGUAGE ExistentialQuantification #-}

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

data/examples/declaration/data/fat-multiline-out.hsnew file+11

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

1+-- | Something.

3+data Foo

4+ = Foo

5+ Int

6+ Int

7+ -- ^ Foo

8+ | Bar

9+ Bool

10+ Bool

11+ -- ^ Bar

data/examples/declaration/data/fat-multiline.hsnew file+9

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

1+-- | Something.

3+data Foo

4+ = Foo Int

5+ Int

6+ -- ^ Foo

7+ | Bar Bool

8+ Bool

9+ -- ^ Bar

data/examples/declaration/data/gadt-syntax-out.hsnew file+3

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

1+{-# LANUGAGE GADTSyntax #-}

2+data Foo where

3+ MKFoo :: a -> (a -> Bool) -> Foo

data/examples/declaration/data/gadt-syntax.hsnew file+3

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

1+{-# LANUGAGE GADTSyntax #-}

3+data Foo where { MKFoo :: a -> (a->Bool) -> Foo }

data/examples/declaration/data/gadt/multiline-out.hsnew file+22

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

1+{-# LANGUAGE ExplicitForAll #-}

3+-- | Here goes a comment.

4+data Foo a where

5+ -- | 'Foo' is wonderful.

6+ Foo

7+ :: forall a b. ( Show a

8+ , Eq b

9+ ) -- foo

10+ -- bar

11+ => a

12+ -> b

13+ -> Foo 'Int

14+ -- | But 'Bar' is also not too bad.

15+ Bar

16+ :: Int

17+ -> Maybe Text

18+ -> Foo 'Bool

19+ -- | So is 'Baz'.

20+ Baz

21+ :: forall a. a

22+ -> Foo 'String

data/examples/declaration/data/gadt/multiline.hsnew file+15

@@ -0,0 +1,15 @@

1+{-# LANGUAGE ExplicitForAll #-}

3+-- | Here goes a comment.

5+data Foo a where

6+ -- | 'Foo' is wonderful.

7+ Foo :: forall a b. (Show a, Eq b) -- foo

8+ -- bar

9+ => a -> b -> Foo 'Int

10+ -- | But 'Bar' is also not too bad.

11+ Bar

12+ :: Int -> Maybe Text -> Foo 'Bool

13+ -- | So is 'Baz'.

14+ Baz

15+ :: forall a. a -> Foo 'String

data/examples/declaration/data/gadt/record-out.hsnew file+11

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

1+-- | Something.

2+data Foo where

3+ Foo :: {fooX :: Int} -> Foo

4+ Bar

5+ :: { fooY :: Int

6+ , fooBar, fooBaz :: Bool

7+ , fooFoo

8+ , barBar

9+ :: Int

10+ }

11+ -> Foo

data/examples/declaration/data/gadt/record.hsnew file+9

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

1+-- | Something.

3+data Foo where

4+ Foo :: { fooX :: Int } -> Foo

5+ Bar :: { fooY :: Int

6+ , fooBar, fooBaz :: Bool

7+ , fooFoo

8+ , barBar :: Int

9+ } -> Foo

data/examples/declaration/data/gadt/simple-out.hsnew file+8

@@ -0,0 +1,8 @@

1+{-# LANGUAGE ExplicitForAll #-}

3+-- | Here goes a comment.

4+data Foo a where

5+ -- | 'Foo' is wonderful.

6+ Foo :: forall a b. (Show a, Eq b) => a -> b -> Foo 'Int

7+ Bar :: Int -> Text -> Foo 'Bool -- ^ But 'Bar' is also not too bad.

8+ Baz :: forall a. a -> Foo 'String -- ^ So is 'Baz'.

data/examples/declaration/data/gadt/simple.hsnew file+9

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

1+{-# LANGUAGE ExplicitForAll #-}

3+-- | Here goes a comment.

5+data Foo a where

6+ -- | 'Foo' is wonderful.

7+ Foo :: forall a b. (Show a, Eq b) => a -> b -> Foo 'Int

8+ Bar :: Int -> Text -> Foo 'Bool -- ^ But 'Bar' is also not too bad.

9+ Baz :: forall a. a -> Foo 'String -- ^ So is 'Baz'.

data/examples/declaration/data/gadt/strictness-out.hsnew file+2

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

1+data Foo a where

2+ Foo :: !Int -> {-# UNPACK #-} !Bool -> Foo Int

data/examples/declaration/data/gadt/strictness.hsnew file+2

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

1+data Foo a where

2+ Foo :: !Int -> {-# UNPACK #-} !Bool -> Foo Int

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

@@ -0,0 +1 @@

1+data Foo a b = a `Foo` b

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

@@ -0,0 +1 @@

1+data Foo a b = a `Foo` b

data/examples/declaration/data/multiline-out.hsnew file+6

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

1+-- | Here we have 'Foo'.

2+data Foo

3+ = Foo -- ^ One

4+ | Bar Int -- ^ Two

5+ | Baz -- ^ Three

6+ deriving (Eq, Show)

data/examples/declaration/data/multiline.hsnew file+7

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

1+-- | Here we have 'Foo'.

3+data Foo

4+ = Foo -- ^ One

5+ | Bar Int -- ^ Two

6+ | Baz -- ^ Three

7+ deriving (Eq, Show)

data/examples/declaration/data/newline-out.hsnew file+3

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

1+-- | Something.

2+newtype Foo = Foo Int

3+ deriving (Eq, Show)

data/examples/declaration/data/newline.hsnew file+4

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

1+-- | Something.

3+newtype Foo = Foo Int

4+ deriving (Eq, Show)

data/examples/declaration/data/record-out.hsnew file+11

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

1+-- | Something.

2+data Foo

3+ = Foo

4+ { fooX :: Int -- ^ X

5+ , fooY :: Int -- ^ Y

6+ , fooBar, fooBaz :: Bool -- ^ BarBaz

7+ , fooFoo

8+ , barBar

9+ :: Int -- ^ Huh!

10+ }

11+ deriving (Eq, Show)

data/examples/declaration/data/record-singleline-out.hsnew file+3

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

1+-- | Something.

2+data Foo = Foo {fooX :: Int, fooY :: Int}

3+ deriving (Eq, Show)

data/examples/declaration/data/record-singleline.hsnew file+4

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

1+-- | Something.

3+data Foo = Foo { fooX :: Int , fooY :: Int }

4+ deriving (Eq, Show)

data/examples/declaration/data/record.hsnew file+9

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

1+-- | Something.

3+data Foo = Foo

4+ { fooX :: Int -- ^ X

5+ , fooY :: Int -- ^ Y

6+ , fooBar, fooBaz :: Bool -- ^ BarBaz

7+ , fooFoo

8+ , barBar :: Int -- ^ Huh!

9+ } deriving (Eq, Show)

data/examples/declaration/data/simple-out.hsnew file+3

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

1+-- | And here we have 'Foo'.

2+data Foo = Foo | Bar Int | Baz

3+ deriving (Eq, Show)

data/examples/declaration/data/simple.hsnew file+4

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

1+-- | And here we have 'Foo'.

3+data Foo = Foo | Bar Int | Baz

4+ deriving (Eq, Show)

data/examples/declaration/data/strictness-out.hsnew file+2

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

1+-- | Something.

2+data Foo = Foo !Int {-# UNPACK #-} !Bool {-# NOUNPACK #-} !String

data/examples/declaration/data/strictness.hsnew file+3

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

1+-- | Something.

3+data Foo = Foo !Int {-# UNPACK #-} !Bool {-# NOUNPACK #-} !String

ormolu.cabal+1

@@ -50,6 +50,7 @@ library

5050 , Ormolu.Printer.Internal

5151 , Ormolu.Printer.Meat.Common

5252 , Ormolu.Printer.Meat.Declaration

53+ , Ormolu.Printer.Meat.Declaration.Data

5354 , Ormolu.Printer.Meat.Declaration.Type

5455 , Ormolu.Printer.Meat.Declaration.TypeFamily

5556 , Ormolu.Printer.Meat.ImportExport

src/Ormolu/Printer/Combinators.hs+57−57

@@ -14,17 +14,21 @@ module Ormolu.Printer.Combinators

1414 , atom

1515 , newline

1616 , inci

17+ , relaxComments

1718 , located

1819 , locatedVia

1920 , located'

21+ , switchLayout

2022 , velt

2123 , velt'

2224 , vlayout

25+ , breakpoint

2326 , withSep

2427 , spaceSep

2528 , newlineSep

2629 -- ** Wrapping

2730 , line

31+ , backticks

2832 , braces

2933 , brackets

3034 , bracketsPar

@@ -32,14 +36,11 @@ module Ormolu.Printer.Combinators

3236 , parensHash

3337 -- ** Literals

3438 , comma

35− , ofType

36− , larrow

37− , rarrow

38− , darrow

3939 , space

4040 )

4141where

4242

43+import Data.Bool (bool)

4344import Data.Data (Data)

4445import Data.List (intersperse)

4546import Data.Text (Text)

@@ -86,47 +87,41 @@ locatedVia

8687 -> R ()

8788locatedVia ml loc@(L l a) f = do

8889 mann <- lookupAnn loc

89− layout <- currentLayout

90− let m = enterLayout

91− (case ml of

92− Nothing -> layout

93− Just l' ->

94− if isOneLineSpan l'

95− then SingleLine

96− else MultiLine)

97− (f a)

90+ relaxed <- relaxedComments

91+ let m = case ml of

92+ Nothing -> f a

93+ Just l' -> switchLayout l' (f a)

9894 case mann of

9995 Nothing -> m

100− Just Ann {..} ->

101− sitcc $ do

102− -- There are three things in 'Ann' which contain comments:

96+ Just Ann {..} -> bool sitcc id relaxed $ do

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

10398

104− let cmode =

105− if annGetConstr a == CN "HsModule"

106− then Module

107− else Other

108− (before, after) = partitionDPs cmode l annsDP

99+ let cmode =

100+ if annGetConstr a == CN "HsModule"

101+ then Module

102+ else Other

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

109104

110− -- 'annPriorComments' contains comments that were directly placed

111− -- before entities such as comments (in both styles) before function

112− -- definitions and inline comments before smaller things like types

113− -- and literals.

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

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

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

108+ -- and literals.

114109

115− spitComments (addDecoration cmode Before l <$> annPriorComments)

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

116111

117− -- Comments inside 'annsDP' marked with 'AnnComment' are trickier,

118− -- they seem to contain everything that goes after the thing they

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

120− -- comments that go before things. Exact location can only be

121− -- deduced by analyzing the associated span.

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

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

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

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

116+ -- deduced by analyzing the associated span.

122117

123− spitComments before

124− m

125− spitComments after

118+ spitComments before

119+ m

120+ spitComments after

126121

127− -- I wasn't able to find any case when 'annFollowingComments' is

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

129− -- have an example of source code where it matters.

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

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

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

130125

131126-- | A version of 'located' with arguments flipped.

132127

@@ -137,6 +132,20 @@ located'

137132 -> R ()

138133located' = flip located

139134

135+-- | Set layout according to given 'SrcSpan' for a given computation. Use

136+-- this only when you need to set layout based on e.g. combined span of

137+-- several elements when there is no corresponding 'Located' wrapper

138+-- provided by GHC AST.

139+

140+switchLayout

141+ :: SrcSpan -- ^ Span that controls layout

142+ -> R () -- ^ Computation to run with changed layout

143+ -> R ()

144+switchLayout spn = enterLayout

145+ (if isOneLineSpan spn

146+ then SingleLine

147+ else MultiLine)

148+

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

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

142151-- current layout.

@@ -159,6 +168,12 @@ velt' xs = sitcc $ sequence_ (intersperse sep (sitcc <$> xs))

159168 where

160169 sep = vlayout (spit " ") newline

161170

171+-- | Insert a space if enclosing layout is single-line, or newline if it's

172+-- multiline.

173+

174+breakpoint :: R ()

175+breakpoint = vlayout space newline

176+

162177-- | Put separator between renderings of items of a list.

163178

164179withSep

@@ -198,6 +213,11 @@ line m = do

198213 m

199214 newline

200215

216+-- | Surround given entity by backticks.

217+

218+backticks :: R () -> R ()

219+backticks m = txt "`" >> m >> txt "`"

220+

201221-- | Surround given entity by curly braces.

202222

203223braces :: R () -> R ()

@@ -252,26 +272,6 @@ ospaces m = vlayout m (txt " " >> m >> newline)

252272comma :: R ()

253273comma = txt ", "

254274

255−-- | Print @::@ followed by a space.

256−

257−ofType :: R ()

258−ofType = txt ":: "

259−

260−-- | Print @<-@ followed by a space.

261−

262−larrow :: R ()

263−larrow = txt "<- "

264−

265−-- | Print @->@ followed by a space.

266−

267−rarrow :: R ()

268−rarrow = txt "-> "

269−

270−-- | Print @=>@ followed by a space.

271−

272−darrow :: R ()

273−darrow = txt "=> "

274−

275275-- | Print single space.

276276

277277space :: R ()

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

@@ -16,10 +16,11 @@ module Ormolu.Printer.Internal

1616 , ensureIndent

1717 , inci

1818 , sitcc

19+ , relaxComments

1920 , Layout (..)

2021 , enterLayout

2122 , vlayout

22− , currentLayout

23+ , relaxedComments

2324 , lookupAnn

2425 )

2526where

@@ -53,6 +54,8 @@ data RC = RC

5354 -- newline if we break lines

5455 , rcLayout :: Layout

5556 -- ^ Current layout

57+ , rcRelaxedComments :: Bool

58+ -- ^ Whether to relax aligning rules for comments

5659 , rcAnns :: Anns

5760 -- ^ The collection of annotations obtained after parsing

5861 , rcDebug :: Bool

@@ -88,6 +91,7 @@ runR debug (R m) anns =

8891 rc = RC

8992 { rcIndent = 0

9093 , rcLayout = MultiLine

94+ , rcRelaxedComments = False

9195 , rcAnns = anns

9296 , rcDebug = debug

9397 }

@@ -168,6 +172,19 @@ sitcc m' = do

168172 vlayout m' (R (local modRC m))

169173 traceR "sitcc_ended" Nothing

170174

175+-- | Relax alignment rules for comments inside this block. This is usually

176+-- done to avoid bumping indentation level too aggressively. Important for

177+-- beautiful rendering of e.g. type signatures.

178+

179+relaxComments :: R () -> R ()

180+relaxComments (R m) = do

181+ traceR "relax_start" Nothing

182+ let modRC x = x

183+ { rcRelaxedComments = True

184+ }

185+ R (local modRC m)

186+ traceR "relax_end" Nothing

187+

171188-- | Set 'Layout' for internal computation.

172189

173190enterLayout :: Layout -> R () -> R ()

@@ -200,6 +217,11 @@ vlayout sline mline = do

200217currentLayout :: R Layout

201218currentLayout = R (asks rcLayout)

202219

220+-- | Check whether we're in a region with relaxed comments placement.

221+

222+relaxedComments :: R Bool

223+relaxedComments = R (asks rcRelaxedComments)

224+

203225-- | Lookup an annotation.

204226

205227lookupAnn :: Data a => Located a -> R (Maybe Annotation)

src/Ormolu/Printer/Meat/Common.hs+21

@@ -10,17 +10,23 @@ module Ormolu.Printer.Meat.Common

1010 , p_rdrName'

1111 , p_qualName

1212 , p_ieWildcard

13+ -- * Helpers

1314 , opParens

15+ , combineSrcSpans'

16+ , getSpan

17+ , unL

1418 )

1519where

1620

1721import Data.Char (isAlphaNum)

22+import Data.List.NonEmpty (NonEmpty (..))

1823import GHC hiding (GhcPs, IE)

1924import Module (Module (..))

2025import OccName (OccName (..))

2126import Ormolu.Printer.Combinators

2227import Outputable (Outputable (..), showSDocUnsafe)

2328import RdrName (RdrName (..), rdrNameOcc)

29+import SrcLoc (combineSrcSpans)

2430

2531p_hsmodName :: ModuleName -> R ()

2632p_hsmodName mname = do

@@ -69,3 +75,18 @@ opParens x m =

6975 if all (not . isAlphaNum) (showSDocUnsafe (ppr x))

7076 then txt "(" >> m >> txt ")"

7177 else m

78+

79+-- | Combine all source spans from the given list.

80+

81+combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan

82+combineSrcSpans' (x:|xs) = foldr combineSrcSpans x xs

83+

84+-- | Get source span from a 'Located' thing.

85+

86+getSpan :: Located e -> SrcSpan

87+getSpan (L spn _) = spn

88+

89+-- | Exact inner value from 'Located'.

90+

91+unL :: Located e -> e

92+unL (L _ e) = e

src/Ormolu/Printer/Meat/Declaration.hs+2

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

1111import HsDecls

1212import Language.Haskell.GHC.ExactPrint.Types

1313import Ormolu.Printer.Combinators

14+import Ormolu.Printer.Meat.Declaration.Data

1415import Ormolu.Printer.Meat.Declaration.Type

1516import Ormolu.Printer.Meat.Declaration.TypeFamily

1617

@@ -23,4 +24,5 @@ p_tyClDecl :: TyClDecl GhcPs -> R ()

2324p_tyClDecl = \case

2425 FamDecl x -> p_famDecl x

2526 SynDecl {..} -> p_synDecl tcdLName tcdTyVars tcdRhs

27+ DataDecl {..} -> p_dataDecl tcdLName tcdTyVars tcdDataDefn

2628 _ -> error "this is not yet supported"

src/Ormolu/Printer/Meat/Declaration/Data.hsnew file+122

@@ -0,0 +1,122 @@

1+{-# LANGUAGE LambdaCase #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE RecordWildCards #-}

5+module Ormolu.Printer.Meat.Declaration.Data

6+ ( p_dataDecl

7+ )

8+where

10+import BasicTypes (DerivStrategy (..))

11+import Control.Monad

12+import Data.List.NonEmpty (nonEmpty)

13+import Data.Maybe (isJust)

14+import GHC hiding (GhcPs, IE)

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

16+import Ormolu.Printer.Combinators

17+import Ormolu.Printer.Meat.Common

18+import Ormolu.Printer.Meat.Type

19+import RdrName (RdrName (..))

20+import SrcLoc (Located)

21+

22+p_dataDecl

23+ :: Located RdrName -- ^ Type constructor

24+ -> LHsQTyVars GhcPs -- ^ Type variables

25+ -> HsDataDefn GhcPs -- ^ Data definition

26+ -> R ()

27+p_dataDecl name tvars HsDataDefn {..} = do

28+ let HsQTvs {..} = tvars

29+ txt $ case dd_ND of

30+ NewType -> "newtype "

31+ DataType -> "data "

32+ located name p_rdrName'

33+ unless (null hsq_explicit) space

34+ spaceSep (located' p_hsTyVarBndr) hsq_explicit

35+ case dd_kindSig of

36+ Nothing -> return ()

37+ Just k -> do

38+ space

39+ txt ":: "

40+ relaxComments (located k p_hsType)

41+ let gadt = isJust dd_kindSig || any (isGadt . unL) dd_cons

42+ case nonEmpty dd_cons of

43+ Nothing -> pure ()

44+ Just dd_cons_ne ->

45+ if gadt

46+ then do

47+ txt " where"

48+ newline

49+ inci $ newlineSep (located' p_conDecl) dd_cons

50+ else switchLayout (combineSrcSpans' (getSpan <$> dd_cons_ne)) $ do

51+ breakpoint

52+ inci $ do

53+ txt "= "

54+ let sep = vlayout (txt " | ") (txt "| ")

55+ velt $ withSep sep (located' p_conDecl) dd_cons

56+ newline

57+ inci . located dd_derivs $ \xs ->

58+ forM_ xs (line . located' p_hsDerivingClause)

59+

60+p_conDecl :: ConDecl GhcPs -> R ()

61+p_conDecl = \case

62+ ConDeclGADT {..} -> velt'

63+ [ spaceSep (located' p_rdrName') con_names

64+ , inci $ do

65+ txt ":: "

66+ relaxComments (locatedVia Nothing (hsib_body con_type) p_hsType)

67+ ]

68+ ConDeclH98 {..} -> do

69+ case hsq_explicit <$> con_qvars of

70+ Nothing -> return ()

71+ Just bndrs -> do

72+ txt "forall "

73+ spaceSep (located' p_hsTyVarBndr) bndrs

74+ txt "."

75+ breakpoint

76+ case con_cxt of

77+ Nothing -> return ()

78+ Just ctx -> located ctx $ \case

79+ [] -> pure ()

80+ xs -> do

81+ p_hsContext xs

82+ breakpoint

83+ txt "=> "

84+ case con_details of

85+ PrefixCon xs -> do

86+ located con_name p_rdrName'

87+ unless (null xs) breakpoint

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

89+ RecCon l -> do

90+ located con_name p_rdrName'

91+ breakpoint

92+ inci $ located l p_conDeclFields

93+ InfixCon x y -> velt'

94+ [ located x p_hsType

95+ , inci $ velt'

96+ [ backticks (located con_name p_rdrName')

97+ , inci $ located y p_hsType

98+ ]

99+ ]

100+

101+isGadt :: ConDecl GhcPs -> Bool

102+isGadt = \case

103+ ConDeclGADT {} -> True

104+ ConDeclH98 {} -> False

105+

106+p_hsDerivingClause

107+ :: HsDerivingClause GhcPs

108+ -> R ()

109+p_hsDerivingClause HsDerivingClause {..} = do

110+ txt "deriving"

111+ case deriv_clause_strategy of

112+ Nothing -> return ()

113+ Just l -> do

114+ space

115+ located l $ \case

116+ StockStrategy -> txt "stock"

117+ AnyclassStrategy -> txt "anyclass"

118+ NewtypeStrategy -> txt "newtype"

119+ breakpoint

120+ inci . located deriv_clause_tys $ \case

121+ [] -> txt "()"

122+ xs -> parens . velt $ withSep comma (located' p_hsType . hsib_body) xs

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

@@ -28,5 +28,5 @@ p_synDecl name tvars t = line $ do

2828 let HsQTvs {..} = tvars

2929 unless (null hsq_explicit) space

3030 spaceSep (located' p_hsTyVarBndr) hsq_explicit

31− vlayout space newline

32− inci (txt "= " >> located t p_hsType)

31+ breakpoint

32+ inci (txt "= " >> relaxComments (located t p_hsType))

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

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

3333 ++ (located' p_injectivityAnn <$> maybeToList fdInjectivityAnn)

3434 spaceSep (located' p_hsTyVarBndr) hsq_explicit

3535 unless (null items) $

36− vlayout space newline

36+ breakpoint

3737 inci . inci $ spaceSep id items

3838 case mmeqs of

3939 Nothing -> newline

@@ -51,18 +51,18 @@ p_familyResultSigL injAnn l =

5151 L _ a -> case a of

5252 NoSig -> Nothing

5353 KindSig k -> Just $ do

54− if injAnn then txt "= " else ofType

55− located k p_hsType

54+ if injAnn then txt "= " else txt ":: "

55+ relaxComments (located k p_hsType)

5656 TyVarSig bndr -> Just $ do

57− if injAnn then txt "= " else ofType

58− located bndr p_hsTyVarBndr

57+ if injAnn then txt "= " else txt ":: "

58+ relaxComments (located bndr p_hsTyVarBndr)

5959

6060p_injectivityAnn :: InjectivityAnn GhcPs -> R ()

6161p_injectivityAnn (InjectivityAnn a bs) = do

6262 txt "| "

6363 located a p_rdrName

6464 space

65− rarrow

65+ txt "-> "

6666 spaceSep (located' p_rdrName) bs

6767

6868p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R ()

src/Ormolu/Printer/Meat/ImportExport.hs+30−30

@@ -22,36 +22,36 @@ p_hsmodExports xs = do

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

2323

2424p_hsmodImport :: ImportDecl GhcPs -> R ()

25−p_hsmodImport ImportDecl {..} = line . velt' $

26− [ do txt "import "

27− when ideclSource $

28− txt "{-# SOURCE #-} "

29− when ideclSafe $

30− txt "safe "

31− when ideclQualified $

32− txt "qualified "

33− case ideclPkgQual of

34− Nothing -> return ()

35− Just slit -> do

36− atom slit

37− space

38− located ideclName atom

39− case ideclAs of

40− Nothing -> return ()

41− Just l -> do

42− txt " as "

43− located l atom

44− case ideclHiding of

45− Nothing -> return ()

46− Just (hiding, _) ->

47− when hiding $

48− txt " hiding"

49− ] ++ (case ideclHiding of

50− Nothing -> []

51− Just (_, l) ->

52− [ inci . locatedVia Nothing l $

53− parens . velt . withSep comma (located' p_lie)

54− ])

25+p_hsmodImport ImportDecl {..} = line $ do

26+ txt "import "

27+ when ideclSource $

28+ txt "{-# SOURCE #-} "

29+ when ideclSafe $

30+ txt "safe "

31+ when ideclQualified $

32+ txt "qualified "

33+ case ideclPkgQual of

34+ Nothing -> return ()

35+ Just slit -> do

36+ atom slit

37+ space

38+ located ideclName atom

39+ case ideclAs of

40+ Nothing -> return ()

41+ Just l -> do

42+ txt " as "

43+ located l atom

44+ case ideclHiding of

45+ Nothing -> return ()

46+ Just (hiding, _) ->

47+ when hiding $

48+ txt " hiding"

49+ case ideclHiding of

50+ Nothing -> return ()

51+ Just (_, l) -> do

52+ breakpoint

53+ inci . locatedVia Nothing l $

54+ parens . velt . withSep comma (located' p_lie)

5555

5656p_lie :: IE GhcPs -> R ()

5757p_lie = \case

src/Ormolu/Printer/Meat/Module.hs+9−10

@@ -29,16 +29,15 @@ p_hsModule loc@(L moduleSpan hsModule) = do

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

3030 case hsmodName of

3131 Nothing -> pure ()

32− Just hsmodName' -> do

33− line . velt' $

34− [ located hsmodName' p_hsmodName ] ++

35− (case hsmodExports of

36− Nothing -> []

37− Just hsmodExports' ->

38− [ inci (locatedVia Nothing hsmodExports' p_hsmodExports)

39− ])

40− ++ [ txt "where"

41− ]

32+ Just hsmodName' -> line $ do

33+ located hsmodName' p_hsmodName

34+ case hsmodExports of

35+ Nothing -> return ()

36+ Just hsmodExports' -> do

37+ breakpoint

38+ inci (locatedVia Nothing hsmodExports' p_hsmodExports)

39+ breakpoint

40+ txt "where"

4241 unless (null hsmodImports) newline

4342 forM_ (sortImports hsmodImports) (located' p_hsmodImport)

4443 when (not (null hsmodImports) && not (null hsmodDecls)) newline

src/Ormolu/Printer/Meat/Type.hs+48−22

@@ -1,11 +1,14 @@

11{-# LANGUAGE LambdaCase #-}

22{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE RecordWildCards #-}

45-- | Rendering of types.

67module Ormolu.Printer.Meat.Type

78 ( p_hsType

9+ , p_hsContext

810 , p_hsTyVarBndr

11+ , p_conDeclFields

912 )

1013where

1114

@@ -16,25 +19,22 @@ import Ormolu.Printer.Meat.Common

1619

1720p_hsType :: HsType GhcPs -> R ()

1821p_hsType = \case

19− HsForAllTy bndrs t -> velt'

20− [ do txt "forall"

21− velt' (located' p_hsTyVarBndr <$> bndrs)

22− txt "."

23− , located t p_hsType

24− ]

25− HsQualTy qs t -> velt'

26− [ locatedVia Nothing qs $ \case

27− [] -> txt "()"

28− [x] -> located x p_hsType

29− xs -> parens . velt $ withSep comma (located' p_hsType) xs

30− , inci $ darrow >> located t p_hsType

31− ]

22+ HsForAllTy bndrs t -> do

23+ txt "forall "

24+ spaceSep (located' p_hsTyVarBndr) bndrs

25+ txt ". "

26+ locatedVia Nothing t p_hsType

27+ HsQualTy qs t -> do

28+ locatedVia Nothing qs p_hsContext

29+ breakpoint

30+ txt "=> "

31+ locatedVia Nothing t p_hsType

3232 HsTyVar p n -> do

3333 case p of

3434 Promoted -> txt "'"

3535 NotPromoted -> return ()

3636 located n p_rdrName

37− HsAppsTy apps -> do

37+ HsAppsTy apps ->

3838 velt' $ case apps of

3939 [] -> []

4040 (x:xs) -> located' p_hsAppType x : (located' (inci . p_hsAppType) <$> xs)

@@ -42,10 +42,14 @@ p_hsType = \case

4242 [ located f p_hsType

4343 , inci $ located x p_hsType

4444 ]

45− HsFunTy f x -> velt'

46− [ located f p_hsType

47− , inci $ rarrow >> located x p_hsType

48− ]

45+ HsFunTy f x@(L _ x') -> do

46+ located f p_hsType

47+ breakpoint

48+ txt "-> "

49+ let located_ = case x' of

50+ HsFunTy{} -> locatedVia Nothing

51+ _ -> located

52+ located_ x p_hsType

4953 HsListTy t -> located t (brackets . p_hsType)

5054 HsPArrTy t -> located t (bracketsPar . p_hsType)

5155 HsTupleTy tsort xs ->

@@ -66,7 +70,7 @@ p_hsType = \case

6670 parens (located t p_hsType)

6771 HsIParamTy n t -> velt'

6872 [ located n atom

69− , inci $ ofType >> located t p_hsType

73+ , inci $ txt ":: " >> located t p_hsType

7074 ]

7175 HsEqTy x y -> velt'

7276 [ located x p_hsType

@@ -74,7 +78,7 @@ p_hsType = \case

7478 ]

7579 HsKindSig t k -> velt'

7680 [ located t p_hsType

77− , inci $ ofType >> located k p_hsType

81+ , inci $ txt ":: " >> located k p_hsType

7882 ]

7983 HsSpliceTy _ _ -> error "HsSpliceTy"

8084 HsDocTy _ _ -> error "HsDocTy"

@@ -88,7 +92,8 @@ p_hsType = \case

8892 SrcStrict -> txt "!"

8993 NoSrcStrict -> return ()

9094 located t p_hsType

91− HsRecTy _ -> error "HsRecTy"

95+ HsRecTy fields ->

96+ p_conDeclFields fields

9297 HsCoreTy t -> atom t

9398 HsExplicitListTy p _ xs -> do

9499 case p of -- XXX not sure about this one

@@ -101,13 +106,19 @@ p_hsType = \case

101106 HsTyLit t -> atom t

102107 HsWildCardTy (AnonWildCard PlaceHolder) -> txt "_"

103108

109+p_hsContext :: HsContext GhcPs -> R ()

110+p_hsContext = \case

111+ [] -> txt "()"

112+ [x] -> located x p_hsType

113+ xs -> parens . velt $ withSep comma (located' p_hsType) xs

114+

104115p_hsTyVarBndr :: HsTyVarBndr GhcPs -> R ()

105116p_hsTyVarBndr = \case

106117 UserTyVar l ->

107118 located l p_rdrName

108119 KindedTyVar l k -> parens $ velt'

109120 [ located l atom

110− , inci $ ofType >> located k p_hsType

121+ , inci $ txt ":: " >> located k p_hsType

111122 ]

112123

113124p_hsAppType :: HsAppType GhcPs -> R ()

@@ -116,3 +127,18 @@ p_hsAppType = \case

116127 located l p_rdrName'

117128 HsAppPrefix l ->

118129 located l p_hsType

130+

131+p_conDeclFields :: [LConDeclField GhcPs] -> R ()

132+p_conDeclFields =

133+ braces . velt . withSep comma (located' p_conDeclField)

134+

135+p_conDeclField :: ConDeclField GhcPs -> R ()

136+p_conDeclField ConDeclField {..} = velt'

137+ [ velt $ withSep

138+ comma

139+ (located' (located' p_rdrName . rdrNameFieldOcc))

140+ cd_fld_names

141+ , inci $ do

142+ txt ":: "

143+ relaxComments (locatedVia Nothing cd_fld_type p_hsType)

144+ ]

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

@@ -66,12 +66,12 @@ rFn :: R ()

6666rFn = velt'

6767 [ txt "foo"

6868 , inci $ velt'

69− [ do ofType

69+ [ do txt ":: "

7070 parens $ velt'

7171 [ txt "Int"

72− , rarrow >> txt "Int"

72+ , txt "-> " >> txt "Int"

7373 ]

74− , rarrow >> txt "Bool"

74+ , txt "-> " >> txt "Bool"

7575 ]

7676 ]

7777