9a0276b · ormolu · git.iko.soy

git.iko.soy/ormolu

Implement the rest of binding types

This includes pattern binds, pattern synonyms, and a refactoring around printing ‘RdrName’s.

commit9a0276b36dbe53998c6d7869d8c4ad12f364a972 authormrkkrp <mark.karpov@tweag.io> dateMon 27 May 2019, 00:24 (7 years ago) parent3874bb6

27 files changed+269−77

compare with master

unifiedsplit

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

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

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

3+pattern HeadC x <- x:xs where

4+ HeadC x = [x]

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

4+pattern Head' x <-

5+ x : xs

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

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

1+{-# LANGUAGE PatternSynonyms #-}

3+pattern Head x <- x:xs

5+pattern Head' x

6+ <- x:xs

ormolu.cabal+1

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

4747 , text >= 0.2 && < 1.3

4848 , yaml >= 0.8 && < 0.12

4949 exposed-modules: Ormolu

50+ , Ormolu.Anns

5051 , Ormolu.CommentStream

5152 , Ormolu.Config

5253 , Ormolu.Diff

src/Ormolu.hs+5−4

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

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

1919import Data.Text (Text)

2020import Debug.Trace

21+import Ormolu.Anns

2122import Ormolu.CommentStream

2223import Ormolu.Config

2324import Ormolu.Diff

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

4748 -> String -- ^ Input to format

4849 -> m Text

4950ormolu cfg path str = do

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

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

5152 parseModule' cfg OrmoluParsingFailed path str

5253 when (cfgDebug cfg) $ do

5354 traceM "warnings:\n"

5455 traceM (concatMap showWarn ws)

5556 traceM "comment stream:\n"

5657 traceM (showCommentStream cstream0)

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

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

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

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

6061 unless (cfgUnsafe cfg) $ do

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

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

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

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

6465 liftIO $ throwIO (OrmoluASTDiffers str txt)

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

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

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

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

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

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

9495 -- ^ Comment stream and parsed source

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

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

src/Ormolu/Anns.hsnew file+48

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

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

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)

1515import GHC hiding (IE, parseModule, parser)

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

1717import GHC.Paths (libdir)

18+import Ormolu.Anns

1819import Ormolu.CommentStream

1920import Ormolu.Config

2021import Ormolu.Exception

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

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

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

3738 -> String -- ^ Input for parser

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

39+ -> m ( [GHC.Warn]

40+ , Either (SrcSpan, String)

41+ (CommentStream, Anns, ParsedSource)

42+ )

3943parseModule dynOpts path input' = liftIO $ do

4044 let (input, extraComments) = stripLinePragmas input'

4145 (ws, dynFlags) <- ghcWrapper $ do

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

4953 when (GHC.xopt Cpp dynFlags) $

5054 throwIO OrmoluCppEnabled

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

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

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

56+ GHC.PFailed _ ss m ->

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

58+ GHC.POk pstate pmod ->

59+ Right ( mkCommentStream extraComments pstate

60+ , mkAnns pstate

61+ , pmod

62+ )

5463 return (ws, r)

5564

5665----------------------------------------------------------------------------

src/Ormolu/Printer.hs+4−2

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

1111

1212import Data.Text (Text)

1313import GHC

14+import Ormolu.Anns

1415import Ormolu.CommentStream

1516import Ormolu.Printer.Combinators

1617import Ormolu.Printer.Meat.Module

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

2122printModule

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

2324 -> CommentStream -- ^ Comment stream

25+ -> Anns -- ^ Annotations

2426 -> ParsedSource -- ^ Parsed source

2527 -> Text -- ^ Resulting rendition

26−printModule debugOn cstream src =

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

28+printModule debugOn cstream anns src =

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

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

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

11{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2+{-# LANGUAGE LambdaCase #-}

23{-# LANGUAGE OverloadedStrings #-}

34{-# LANGUAGE RankNTypes #-}

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

3031 , setIndent

3132 , getEnclosingSpan

3233 , withEnclosingSpan

34+ -- * Annotations

35+ , getAnns

3336 )

3437where

3538

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

4144import Data.Text.Lazy.Builder

4245import Debug.Trace

4346import GHC

47+import Ormolu.Anns

4448import Ormolu.CommentStream

4549import Ormolu.SpanStream

4650import SrcLoc

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

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

7175 , rcEnclosingSpan :: Maybe RealSrcSpan

7276 -- ^ Span of enclosing element of AST

77+ , rcAnns :: Anns

78+ -- ^ Collection of annotations

7379 }

7480

7581-- | State context of 'R'.

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

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

102108 -> SpanStream -- ^ Span stream

103109 -> CommentStream -- ^ Comment stream

110+ -> Anns -- ^ Annotations

104111 -> Text -- ^ Resulting rendition

105−runR debug (R m) sstream cstream =

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

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

107114 where

108115 rc = RC

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

111118 , rcRelaxedComments = False

112119 , rcDebug = debug

113120 , rcEnclosingSpan = Nothing

121+ , rcAnns = anns

114122 }

115123 sc = SC

116124 { scColumn = 0

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

322330 }

323331 R (local modRC m)

324332

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+

325343----------------------------------------------------------------------------

326344-- Debug helpers

327345

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

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

77 ( p_hsmodName

88 , p_ieWrappedName

99 , p_rdrName

10− , p_rdrName'

1110 , p_qualName

1211 , p_ieWildcard

13− , opParens

1412 )

1513where

1614

17−import Data.Char (isAlphaNum)

1815import GHC hiding (GhcPs, IE)

1916import Module (Module (..))

2017import OccName (OccName (..))

2118import Ormolu.Printer.Combinators

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

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

19+import Ormolu.Printer.Internal (getAnns)

20+import Ormolu.Utils (getSpan)

21+import RdrName (RdrName (..))

2422

2523p_hsmodName :: ModuleName -> R ()

2624p_hsmodName mname = do

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

2927

3028p_ieWrappedName :: IEWrappedName RdrName -> R ()

3129p_ieWrappedName = \case

32− IEName l2 -> located l2 p_rdrName

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

30+ IEName x -> p_rdrName x

31+ IEPattern x -> do

3432 txt "pattern "

3533 p_rdrName x

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

34+ IEType x -> do

3735 txt "type "

3836 p_rdrName x

3937

40−p_rdrName :: RdrName -> R ()

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

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

4239

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

44−p_rdrName' x = case x of

45− Unqual occName -> atom occName

46− Qual mname occName -> p_qualName mname occName

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

48− Exact name -> atom name

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 $

54+ case x of

55+ Unqual occName -> atom occName

56+ Qual mname occName -> p_qualName mname occName

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

58+ Exact name -> atom name

4959

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

5161p_qualName mname occName = do

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

5767p_ieWildcard = \case

5868 NoIEWildcard -> return ()

5969 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

3030 txt $ case dd_ND of

3131 NewType -> "newtype "

3232 DataType -> "data "

33− located name p_rdrName'

33+ p_rdrName name

3434 unless (null hsq_explicit) space

3535 spaceSep (located' p_hsTyVarBndr) hsq_explicit

3636 case dd_kindSig of

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

5959p_conDecl :: ConDecl GhcPs -> R ()

6060p_conDecl = \case

6161 ConDeclGADT {..} -> do

62− spaceSep (located' p_rdrName) con_names

62+ spaceSep p_rdrName con_names

6363 breakpoint

6464 inci $ do

6565 txt ":: "

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

8383 forM_ con_mb_cxt p_lhsContext

8484 case con_args of

8585 PrefixCon xs -> do

86− located con_name p_rdrName

86+ p_rdrName con_name

8787 unless (null xs) breakpoint

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

8989 RecCon l -> do

90− located con_name p_rdrName

90+ p_rdrName con_name

9191 breakpoint

9292 inci $ located l p_conDeclFields

9393 InfixCon x y -> do

9494 located x p_hsType

9595 breakpoint

9696 inci $ do

97− backticks (located con_name p_rdrName)

98− breakpoint

99− inci (located y p_hsType)

97+ p_rdrName con_name

98+ space

99+ located y p_hsType

100100 XConDecl NoExt -> notImplemented "XConDecl"

101101

102102p_forallBndrs

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

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

1717p_pat :: Pat GhcPs -> R ()

1818p_pat = \case

1919 WildPat NoExt -> txt "_"

20− VarPat NoExt name -> located name p_rdrName

20+ VarPat NoExt name -> p_rdrName name

2121 LazyPat NoExt pat -> do

2222 txt "~"

2323 located pat p_pat

2424 AsPat NoExt name pat -> do

25− located name p_rdrName

25+ p_rdrName name

2626 txt "@"

2727 located pat p_pat

2828 ParPat NoExt pat ->

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

4343 located pat p_pat

4444 ConPatIn pat details ->

4545 case details of

46− PrefixCon xs -> do

47− located pat p_rdrName

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

46+ PrefixCon xs -> sitcc $ do

47+ p_rdrName pat

48+ unless (null xs) $ do

4949 breakpoint

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

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

5151 RecCon (HsRecFields fields dotdot) -> do

52− located pat p_rdrName

52+ p_rdrName pat

5353 case dotdot of

5454 Nothing -> txt " {..}"

5555 Just _ -> do

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

5757 InfixCon x y -> do

5858 located x p_pat

59− located pat (backticks . p_rdrName)

60− located y p_pat

59+ breakpoint

60+ inci $ do

61+ p_rdrName pat

62+ space

63+ located y p_pat

6164 ConPatOut {} -> notImplemented "ConPatOut"

6265 ViewPat {} -> notImplemented "ViewPat"

6366 SplicePat {} -> notImplemented "SplicePat"

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

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

7275p_hsRecField HsRecField {..} =

7376 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

2929 -> LHsSigWcType GhcPs

3030 -> R ()

3131p_typeSig names HsWC {..} = do

32− spaceSep (located' p_rdrName) names

32+ spaceSep p_rdrName names

3333 breakpoint

3434 inci $ do

3535 txt ":: "

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

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

2323 -> R ()

2424p_synDecl name tvars t = line $ do

2525 txt "type "

26− located name p_rdrName'

26+ p_rdrName name

2727 let HsQTvs {..} = tvars

2828 unless (null hsq_explicit) space

2929 spaceSep (located' p_hsTyVarBndr) hsq_explicit

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

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

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

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

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

27− located fdLName p_rdrName

27+ p_rdrName fdLName

2828 space

2929 let HsQTvs {..} = fdTyVars

3030 items =

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

6565p_injectivityAnn :: InjectivityAnn GhcPs -> R ()

6666p_injectivityAnn (InjectivityAnn a bs) = do

6767 txt "| "

68− located a p_rdrName

68+ p_rdrName a

6969 space

7070 txt "-> "

71− spaceSep (located' p_rdrName) bs

71+ spaceSep p_rdrName bs

7272

7373p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R ()

7474p_tyFamInstEqn HsIB {..} = do

7575 let FamEqn {..} = hsib_body

76− located feqn_tycon p_rdrName

76+ p_rdrName feqn_tycon

7777 space

7878 spaceSep (located' p_hsType) feqn_pats

7979 txt " ="

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

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

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

2727p_valDecl' = \case

2828 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"

3034

3135p_funBind

32− :: Located RdrName -- ^

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

36+ :: Located RdrName

37+ -> MatchGroup GhcPs (LHsExpr GhcPs)

3438 -> R ()

3539p_funBind name mgroup =

36− p_matchGroup (Function (unL name)) mgroup

40+ p_matchGroup (Function name) mgroup

3741

3842data MatchGroupStyle

39− = Function RdrName

43+ = Function (Located RdrName)

44+ | PatternBind

4045 | Case

4146 | Lambda

4247 | LambdaCase

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

4752 -> R ()

4853p_matchGroup style MG {..} =

4954 locatedVia Nothing mg_alts $

50− newlineSep (located' (p_match style))

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

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

5257

5358p_match

5459 :: MatchGroupStyle

55− -> Match GhcPs (LHsExpr GhcPs)

60+ -> [LPat GhcPs]

61+ -> GRHSs GhcPs (LHsExpr GhcPs)

5662 -> R ()

57−p_match style Match {..} = do

63+p_match style m_pats m_grhss = do

5864 case style of

5965 Function name -> p_rdrName name

6066 _ -> return ()

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

7682 switchLayout combinedSpans $ do

7783 case style of

7884 Function _ -> breakpoint

85+ PatternBind -> return ()

7986 Case -> return ()

8087 Lambda -> txt "\\"

8188 LambdaCase -> return ()

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

89+ let wrapper = case style of

90+ Function _ -> inci'

91+ _ -> id

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

8393 return inci'

8494 inci' $ do

8595 let GRHSs {..} = m_grhss

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

8797 space

8898 txt $ case style of

8999 Function _ -> "="

100+ PatternBind -> "="

90101 _ -> "->"

91102 let combinedSpans = combineSrcSpans' $

92103 getGRHSSpan . unL <$> NE.fromList grhssGRHSs

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

102113 newline

103114 line (txt "where")

104115 inci (located grhssLocalBinds p_hsLocalBinds)

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

106116

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

108118p_grhs (GRHS NoExt guards body) =

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

148158

149159p_hsExpr :: HsExpr GhcPs -> R ()

150160p_hsExpr = \case

151− HsVar NoExt name -> located name p_rdrName'

161+ HsVar NoExt name -> p_rdrName name

152162 HsUnboundVar NoExt _ -> notImplemented "HsUnboundVar"

153163 HsConLikeOut NoExt _ -> notImplemented "HsConLikeOut"

154164 HsRecFld NoExt x ->

155165 case x of

156− Unambiguous NoExt name -> located name p_rdrName'

157− Ambiguous NoExt name -> located name p_rdrName'

166+ Unambiguous NoExt name -> p_rdrName name

167+ Ambiguous NoExt name -> p_rdrName name

158168 XAmbiguousFieldOcc NoExt -> notImplemented "XAmbiguousFieldOcc"

159169 HsOverLabel NoExt _ _ -> notImplemented "HsOverLabel"

160170 HsIPVar NoExt (HsIPName name) -> atom name

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

247257 HsWrap {} -> notImplemented "HsWrap"

248258 XExpr {} -> notImplemented "XExpr"

249259

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+

250299----------------------------------------------------------------------------

251300-- Helpers

252301

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

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

3333 case p of

3434 Promoted -> txt "'"

3535 NotPromoted -> return ()

36− located n p_rdrName'

36+ p_rdrName n

3737 HsAppTy NoExt f x -> sitcc $ do

3838 located f p_hsType

3939 breakpoint

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

6161 located x p_hsType

6262 breakpoint

6363 inci $ do

64− located op p_rdrName'

64+ p_rdrName op

6565 space

6666 located y p_hsType

6767 HsParTy NoExt t ->

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

112112

113113p_hsTyVarBndr :: HsTyVarBndr GhcPs -> R ()

114114p_hsTyVarBndr = \case

115− UserTyVar NoExt l ->

116− located l p_rdrName

115+ UserTyVar NoExt x ->

116+ p_rdrName x

117117 KindedTyVar NoExt l k -> parens $ do

118118 located l atom

119119 breakpoint

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

130130p_conDeclField ConDeclField {..} = do

131131 sitcc . velt $ withSep

132132 comma

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

133+ (located' (p_rdrName . rdrNameFieldOcc))

134134 cd_fld_names

135135 breakpoint

136136 sitcc . inci $ do

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

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

33module Ormolu.Printer.CombinatorsSpec (spec) where

5+import Ormolu.Anns

56import Ormolu.Printer.Combinators

67import Ormolu.Printer.Internal

78import Test.Hspec

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

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

9798shouldRender m path = do

9899 expected <- T.readFile path

99− runR False m mempty mempty `shouldBe` expected

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

100101

101102-- | Render using single-line layout.

102103