244144d · ormolu · git.iko.soy

git.iko.soy/ormolu

Fix rendering of infix constructions in lhs of definitions

Also includes a minor refactoring of how type families are rendered.

commit244144d6f47c276b413b0c873c651ecc5b35f388 authormrkkrp <mark.karpov@tweag.io> dateWed 12 Jun 2019, 20:07 (7 years ago) parent695842e

13 files changed+176−54

compare with master

unifiedsplit

data/examples/declaration/instance/associated-types-out.hs+7−4

@@ -3,7 +3,10 @@ instance Foo Int where

33 type Bar Int = Double

55instance Foo Double where

6− type Bar Double =

7− [Double]

8− type Baz Double =

9− [Double]

6+ type

7+ Bar

8+ Double =

9+ [Double]

10+ type

11+ Baz Double =

12+ [Double]

data/examples/declaration/instance/type-family-instances-out.hs+14−8

@@ -1,14 +1,20 @@

11{-# LANGUAGE TypeFamilies #-}

22type instance Foo Int = Int

4−type instance Foo [Int] =

5− ( Int

6− , Int

7− )

4+type instance

5+ Foo

6+ [Int] =

7+ ( Int

8+ , Int

9+ )

810

911type instance Bar Int [Int] Double = (Int, Double)

1012

11−type instance Bar [Int] [Int] Double =

12− ( Int

13− , Double

14− )

13+type instance

14+ Bar

15+ [Int]

16+ [Int]

17+ Double =

18+ ( Int

19+ , Double

20+ )

data/examples/declaration/type-families/closed-type-family/infix-out.hsnew file+11

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

1+type family (x :: N) + (y :: N) :: N where

2+ 'Zero + y = y

3+ 'Succ n + y = 'Succ (n + y)

5+type family (x :: N) `LEQ` (y :: N) :: Bool where

6+ 'Zero `LEQ` y = 'True

7+ 'Succ n `LEQ` 'Zero = 'False

8+ 'Succ n `LEQ` 'Succ m = n `LEQ` m

10+type family ((x :: N) `Weird` (y :: N)) (z :: N) :: Bool where

11+ 'Zero `Weird` 'Zero 'Zero = 'True

data/examples/declaration/type-families/closed-type-family/infix.hsnew file+11

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

1+type family (x :: N) + (y :: N) :: N where

2+ 'Zero + y = y

3+ 'Succ n + y = 'Succ (n + y)

5+type family (x :: N) `LEQ` (y :: N) :: Bool where

6+ 'Zero `LEQ` y = 'True

7+ 'Succ n `LEQ` 'Zero = 'False

8+ 'Succ n `LEQ` 'Succ m = n `LEQ` m

10+type family ((x :: N) `Weird` (y :: N)) (z :: N) :: Bool where

11+ 'Zero `Weird` 'Zero 'Zero = 'True

data/examples/declaration/type-families/closed-type-family/multi-line-out.hs+13−5

@@ -1,14 +1,22 @@

1−type family Id a

2− = result | result -> a where

1+type family

2+ Id a

3+ = result

4+ | result -> a where

35 Id a =

46 a

6−type family G (a :: k) b c

7− = foo | foo -> k b where

8+type family

9+ G

10+ (a :: k)

11+ b

12+ c

13+ = foo

14+ | foo -> k b where

815 G a b c =

916 (a, b)

1017

11−type family F a

18+type family

19+ F a

1220 :: * -> * where

1321 F Int = Double

1422 F Bool =

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

@@ -0,0 +1 @@

1+foo x y = x `bar` y

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

@@ -0,0 +1 @@

1+foo x y = x `bar` y

data/examples/declaration/value/function/infix-out.hs+12−1

@@ -1 +1,12 @@

1−foo x y = x `bar` y

1+(*) :: Int -> Int -> Int

2+x * y = z

4+foo :: Int -> Int -> Int

5+x `foo` y = z

7+bar :: Int -> Int -> Int -> Int

8+(x `bar` y) z = z

10+multiline :: Int -> Int -> Int

11+x `multiline`

12+ y = z

data/examples/declaration/value/function/infix.hs+12−1

@@ -1 +1,12 @@

1−foo x y = x `bar` y

1+(*) :: Int -> Int -> Int

2+x * y = z

4+foo :: Int -> Int -> Int

5+x `foo` y = z

7+bar :: Int -> Int -> Int -> Int

8+(x `bar` y) z = z

10+multiline :: Int -> Int -> Int

11+x `multiline`

12+ y = z

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

@@ -10,9 +10,11 @@ module Ormolu.Printer.Meat.Common

1010 , p_rdrName

1111 , p_qualName

1212 , p_ieWildcard

13+ , p_infixDefHelper

1314 )

1415where

1516

17+import Control.Monad

1618import Data.List (isPrefixOf)

1719import GHC hiding (GhcPs, IE)

1820import Module (Module (..))

@@ -86,3 +88,33 @@ p_ieWildcard :: IEWildcard -> R ()

8688p_ieWildcard = \case

8789 NoIEWildcard -> return ()

8890 IEWildcard n -> parens (atom n)

91+

92+-- | A helper for formatting infix constructions in lhs of definitions.

93+

94+p_infixDefHelper

95+ :: Bool -- ^ Whether to format in infix style

96+ -> (R () -> R ()) -- ^ Indentation-bumping wrapper

97+ -> R () -- ^ How to print the operator\/name

98+ -> [R ()] -- ^ How to print the arguments

99+ -> R ()

100+p_infixDefHelper isInfix inci' name args =

101+ case (isInfix, args) of

102+ (True, p0:p1:ps) -> do

103+ let parens' =

104+ if null ps

105+ then id

106+ else parens

107+ parens' $ do

108+ p0

109+ space

110+ name

111+ breakpoint

112+ inci' p1

113+ unless (null ps) . inci' $ do

114+ breakpoint

115+ velt' ps

116+ (_, ps) -> do

117+ name

118+ unless (null ps) $ do

119+ breakpoint

120+ inci' (velt' args)

src/Ormolu/Printer/Meat/Declaration/Instance.hs+4−3

@@ -69,9 +69,10 @@ p_tyFamInstDecl :: FamilyStyle -> TyFamInstDecl GhcPs -> R ()

6969p_tyFamInstDecl style = \case

7070 TyFamInstDecl {..} -> do

7171 txt $ case style of

72− Associated -> "type "

73− Free -> "type instance "

74− p_tyFamInstEqn tfid_eqn

72+ Associated -> "type"

73+ Free -> "type instance"

74+ breakpoint

75+ inci (p_tyFamInstEqn tfid_eqn)

7576 newline

7677

7778p_dataFamInstDecl :: FamilyStyle -> DataFamInstDecl GhcPs -> R ()

src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs+37−16

@@ -10,8 +10,10 @@ module Ormolu.Printer.Meat.Declaration.TypeFamily

1010 )

1111where

1212

13+import BasicTypes (LexicalFixity (..))

1314import Control.Monad

14−import Data.Maybe (maybeToList, isJust)

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

16+import Data.Maybe (isNothing, isJust)

1517import GHC

1618import Ormolu.Printer.Combinators

1719import Ormolu.Printer.Meat.Common

@@ -22,19 +24,26 @@ import SrcLoc (Located, GenLocated (..))

2224p_famDecl :: FamilyDecl GhcPs -> R ()

2325p_famDecl FamilyDecl {..} = do

2426 mmeqs <- case fdInfo of

25− DataFamily -> Nothing <$ txt "data family "

26− OpenTypeFamily -> Nothing <$ txt "type family "

27− ClosedTypeFamily eqs -> Just eqs <$ txt "type family "

28− p_rdrName fdLName

29− space

27+ DataFamily -> Nothing <$ txt "data family"

28+ OpenTypeFamily -> Nothing <$ txt "type family"

29+ ClosedTypeFamily eqs -> Just eqs <$ txt "type family"

30+ breakpoint

3031 let HsQTvs {..} = fdTyVars

31− items =

32− maybeToList (p_familyResultSigL (isJust fdInjectivityAnn) fdResultSig)

33− ++ (located' p_injectivityAnn <$> maybeToList fdInjectivityAnn)

34− spaceSep (located' p_hsTyVarBndr) hsq_explicit

35− unless (null items) $

36− breakpoint

37− inci . inci $ spaceSep id items

32+ combinedSpans = combineSrcSpans' $

33+ getSpan fdLName :| fmap getSpan hsq_explicit

34+ inci $ do

35+ switchLayout combinedSpans $ p_infixDefHelper

36+ (isInfix fdFixity)

37+ inci

38+ (p_rdrName fdLName)

39+ (located' p_hsTyVarBndr <$> hsq_explicit)

40+ let rsig = p_familyResultSigL (isJust fdInjectivityAnn) fdResultSig

41+ unless (isNothing rsig && isNothing fdInjectivityAnn) $

42+ breakpoint

43+ inci $ do

44+ sequence_ rsig

45+ when (isJust rsig && isJust fdInjectivityAnn) breakpoint

46+ forM_ fdInjectivityAnn (located' p_injectivityAnn)

3847 case mmeqs of

3948 Nothing -> newline

4049 Just meqs -> do

@@ -74,10 +83,22 @@ p_injectivityAnn (InjectivityAnn a bs) = do

7483p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R ()

7584p_tyFamInstEqn HsIB {..} = do

7685 let FamEqn {..} = hsib_body

77− p_rdrName feqn_tycon

78− space

79− spaceSep (located' p_hsType) feqn_pats

86+ combinedSpans = combineSrcSpans' $

87+ getSpan feqn_tycon :| fmap getSpan feqn_pats

88+ switchLayout combinedSpans $ p_infixDefHelper

89+ (isInfix feqn_fixity)

90+ inci

91+ (p_rdrName feqn_tycon)

92+ (located' p_hsType <$> feqn_pats)

8093 txt " ="

8194 breakpoint

8295 inci (located feqn_rhs p_hsType)

8396p_tyFamInstEqn (XHsImplicitBndrs NoExt) = notImplemented "XHsImplicitBndrs"

97+

98+----------------------------------------------------------------------------

99+-- Helpers

100+

101+isInfix :: LexicalFixity -> Bool

102+isInfix = \case

103+ Infix -> True

104+ Prefix -> False

src/Ormolu/Printer/Meat/Declaration/Value.hs+21−16

@@ -54,7 +54,7 @@ p_valDecl = line . p_valDecl'

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

5555p_valDecl' = \case

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

57− PatBind NoExt pat grhss _ -> p_match PatternBind [pat] grhss

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

5858 VarBind {} -> notImplemented "VarBinds" -- introduced by the type checker

5959 AbsBinds {} -> notImplemented "AbsBinds" -- introduced by the type checker

6060 PatSynBind NoExt psb -> p_patSynBind psb

@@ -73,18 +73,17 @@ p_matchGroup

7373 -> R ()

7474p_matchGroup style MG {..} =

7575 locatedVia Nothing mg_alts $

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

76+ newlineSep (located' (\m@Match {..} ->

77+ p_match style (isInfixMatch m) m_pats m_grhss))

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

7879

7980p_match

8081 :: MatchGroupStyle

82+ -> Bool -- ^ Is this an infix match?

8183 -> [LPat GhcPs]

8284 -> GRHSs GhcPs (LHsExpr GhcPs)

8385 -> R ()

84−p_match style m_pats m_grhss = do

85− case style of

86− Function name -> p_rdrName name

87− _ -> return ()

86+p_match style isInfix m_pats m_grhss = do

8887 -- NOTE Normally, since patterns may be placed in a multi-line layout, it

8988 -- is necessary to bump indentation for the pattern group so it's more

9089 -- indented than function name. This in turn means that indentation for

@@ -93,7 +92,9 @@ p_match style m_pats m_grhss = do

9392 -- need to be a bit more clever here and bump indentation level only when

9493 -- pattern group is multiline.

9594 inci' <- case NE.nonEmpty m_pats of

96− Nothing -> return id

95+ Nothing -> id <$ case style of

96+ Function name -> p_rdrName name

97+ _ -> return ()

9798 Just ne_pats -> do

9899 let combinedSpans = combineSrcSpans' $

99100 getSpan <$> ne_pats

@@ -101,16 +102,20 @@ p_match style m_pats m_grhss = do

101102 then id

102103 else inci

103104 switchLayout combinedSpans $ do

105+ let stdCase = velt' (located' p_pat <$> m_pats)

104106 case style of

105− Function _ -> breakpoint

106− PatternBind -> return ()

107− Case -> return ()

108− Lambda -> txt "\\"

109− LambdaCase -> return ()

110− let wrapper = case style of

111− Function _ -> inci'

112− _ -> id

113− wrapper (velt' (located' p_pat <$> m_pats))

107+ Function name ->

108+ p_infixDefHelper

109+ isInfix

110+ inci'

111+ (p_rdrName name)

112+ (located' p_pat <$> m_pats)

113+ PatternBind -> stdCase

114+ Case -> stdCase

115+ Lambda -> do

116+ txt "\\"

117+ stdCase

118+ LambdaCase -> stdCase

114119 return inci'

115120 inci' $ do

116121 let GRHSs {..} = m_grhss