99a345b · ormolu · git.iko.soy

git.iko.soy/ormolu

Initial support for do notation

commit99a345b9196ca2b4afc7666f1d24c97bafe96abe authorUtku Demir <me@utdemir.com> dateWed 29 May 2019, 22:27 (7 years ago) parent6bc7333

5 files changed+101−31

compare with master

unifiedsplit

data/examples/declaration/value/function/do-out.hs+22 data/examples/declaration/value/function/do.hs+18 data/examples/declaration/value/function/lambda-case-out.hs+3−4 data/examples/declaration/value/function/lambda-multi-line-out.hs+6−8 src/Ormolu/Printer/Meat/Declaration/Value.hs+52−19

data/examples/declaration/value/function/do-out.hsnew file+22

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

1+{-# LANGUAGE RecursiveDo #-}

2+bar = do

3+ foo

4+ bar

6+baz = mdo

7+ bar a

8+ a <- foo

9+ b <-

10+ bar

11+ 1

12+ 2

13+ 3

14+ return (a + b)

15+

16+baz = do

17+ a <- foo

18+ let b = a + 2

19+ c = b + 3

20+ bar c

21+ let d = c + 2

22+ return d

data/examples/declaration/value/function/do.hsnew file+18

@@ -0,0 +1,18 @@

1+{-# LANGUAGE RecursiveDo #-}

3+bar = do { foo; bar }

5+baz =

6+ mdo bar a

7+ a <- foo

8+ b <- bar

9+ 1 2 3

10+ return (a + b)

11+

12+baz = do

13+ a <- foo

14+ let b = a + 2

15+ c = b + 3

16+ bar c

17+ let d = c + 2

18+ return d

data/examples/declaration/value/function/lambda-case-out.hs+3−4

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

11{-# LANGUAGE LambdaCase #-}

22foo :: Int -> Int

3−foo =

4− \case

5− 5 -> 10

6− _ -> 12

3+foo = \case

4+ 5 -> 10

5+ _ -> 12

data/examples/declaration/value/function/lambda-multi-line-out.hs+6−8

@@ -1,11 +1,9 @@

11foo :: a -> a -> a

2−foo x =

3− \y ->

4− x

2+foo x = \y ->

3+ x

65bar :: Int -> Int -> Int

7−bar x =

8− \y ->

9− if x > y

10− then 10

11− else 12

6+bar x = \y ->

7+ if x > y

8+ then 10

9+ else 12

src/Ormolu/Printer/Meat/Declaration/Value.hs+52−19

@@ -30,8 +30,8 @@ p_valDecl' :: HsBindLR GhcPs GhcPs -> R ()

3030p_valDecl' = \case

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

3232 PatBind NoExt pat grhss _ -> p_match PatternBind [pat] grhss

33− VarBind {} -> error "VarBinds are introduced by the type checker"

34− AbsBinds {} -> error "AbsBinds are introduced by the type checker"

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

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

3535 PatSynBind NoExt psb -> p_patSynBind psb

3636 XHsBindsLR NoExt -> notImplemented "XHsBindsLR"

3737

@@ -104,18 +104,23 @@ p_match style m_pats m_grhss = do

104104 _ -> "->"

105105 let combinedSpans = combineSrcSpans' $

106106 getGRHSSpan . unL <$> NE.fromList grhssGRHSs

107+ breakpoint' =

108+ if isPrefixBlock grhssGRHSs

109+ then space

110+ else breakpoint

111+ p_body = do

112+ newlineSep (located' (p_grhs Guard)) grhssGRHSs

113+ unless (GHC.isEmptyLocalBindsPR (unL grhssLocalBinds)) $ do

114+ newline

115+ line (txt "where")

116+ inci (located grhssLocalBinds p_hsLocalBinds)

107117 case style of

108− Lambda -> breakpoint

109− _ -> return ()

110− switchLayout combinedSpans . inci $ do

111− case style of

112− Lambda -> return ()

113− _ -> breakpoint

114− newlineSep (located' (p_grhs Guard)) grhssGRHSs

115− unless (GHC.isEmptyLocalBindsPR (unL grhssLocalBinds)) $ do

116− newline

117− line (txt "where")

118− inci (located grhssLocalBinds p_hsLocalBinds)

118+ Lambda -> do

119+ breakpoint'

120+ switchLayout combinedSpans p_body

121+ _ -> switchLayout combinedSpans . inci $ do

122+ breakpoint'

123+ p_body

119124

120125data GroupStyle

121126 = Guard

@@ -140,11 +145,19 @@ p_grhs _ (XGRHS NoExt) = notImplemented "XGRHS"

140145

141146p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()

142147p_stmt = \case

143− LastStmt {} -> notImplemented "do notation"

144− BindStmt {} -> notImplemented "do notation"

145− ApplicativeStmt {} -> notImplemented "applicative stmt"

148+ LastStmt NoExt _ _ _ ->

149+ notImplemented "LastStmt" -- only available after renamer

150+ BindStmt NoExt l f _ _ -> do

151+ located l p_pat

152+ space

153+ txt "<-"

154+ breakpoint

155+ inci (located f p_hsExpr)

156+ ApplicativeStmt {} -> notImplemented "ApplicativeStmt"

146157 BodyStmt NoExt body _ _ -> located body p_hsExpr

147− LetStmt NoExt binds -> located binds p_hsLocalBinds

158+ LetStmt NoExt binds -> do

159+ txt "let "

160+ sitcc $ located binds p_hsLocalBinds

148161 ParStmt {} -> notImplemented "ParStmt"

149162 TransStmt {} -> notImplemented "TransStmt"

150163 RecStmt {} -> notImplemented "RecStmt"

@@ -203,7 +216,7 @@ p_hsExpr = \case

203216 HsLamCase NoExt mgroup -> do

204217 txt "\\case"

205218 newline

206− inci (p_matchGroup LambdaCase mgroup)

219+ p_matchGroup LambdaCase mgroup

207220 HsApp NoExt f x -> do

208221 located f p_hsExpr

209222 breakpoint

@@ -287,7 +300,13 @@ p_hsExpr = \case

287300 breakpoint

288301 txt "in "

289302 sitcc (located e p_hsExpr)

290− HsDo {} -> notImplemented "HsDo"

303+ HsDo NoExt ctx es -> do

304+ case ctx of

305+ DoExpr -> txt "do"

306+ MDoExpr -> txt "mdo"

307+ _ -> notImplemented "certain kinds of do notation"

308+ newline

309+ located es (newlineSep (located' p_stmt))

291310 ExplicitList _ _ xs -> do

292311 brackets $ velt (withSep comma (located' p_hsExpr) xs)

293312 RecordCon {..} -> do

@@ -411,3 +430,17 @@ p_patSynDetails = \case

411430getGRHSSpan :: GRHS GhcPs (LHsExpr GhcPs) -> SrcSpan

412431getGRHSSpan (GRHS NoExt _ body) = getSpan body

413432getGRHSSpan (XGRHS NoExt) = notImplemented "XGRHS"

433+

434+-- | Check the body is such a thing that prints a short prefix and then the

435+-- rest goes after a newline. In that case we can leave the prefix on

436+-- current line. Examples of such things are: lambdas, do-blocks, and lambda

437+-- case expressions.

438+

439+isPrefixBlock :: [LGRHS GhcPs (LHsExpr GhcPs)] -> Bool

440+isPrefixBlock [(L _ (GRHS NoExt _ (L _ e)))] =

441+ case e of

442+ HsLam NoExt _ -> True

443+ HsDo NoExt _ _ -> True

444+ HsLamCase NoExt _ -> True

445+ _ -> False

446+isPrefixBlock _ = False