git.iko.soy/ormolu
on master help sign in
Initial support for do notation
99a345bUtku Demir
data/examples/declaration/value/function/do-out.hsnew file+22
compare with master
unifiedsplit
@@ -0,0 +1,22 @@
1+{-# LANGUAGE RecursiveDo #-}
2+bar = do
3+ foo
4+ bar
5+
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 #-}
2+
3+bar = do { foo; bar }
4+
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 @@
1{-# LANGUAGE LambdaCase #-}
1{-# LANGUAGE LambdaCase #-}
2foo :: Int -> Int
2foo :: Int -> Int
3−foo =
4− \case
3+foo = \case
5− 5 -> 10
4+ 5 -> 10
6− _ -> 12
5+ _ -> 12
data/examples/declaration/value/function/lambda-multi-line-out.hs+6−8
@@ -1,11 +1,9 @@
1foo :: a -> a -> a
1foo :: a -> a -> a
2−foo x =
2+foo x = \y ->
3− \y ->
4− x
3+ x
5
4
6bar :: Int -> Int -> Int
5bar :: Int -> Int -> Int
7−bar x =
6+bar x = \y ->
8− \y ->
9− if x > y
7+ if x > y
10− then 10
8+ then 10
11− else 12
9+ else 12
src/Ormolu/Printer/Meat/Declaration/Value.hs+52−19
@@ -30,8 +30,8 @@ p_valDecl' :: HsBindLR GhcPs GhcPs -> R ()
30p_valDecl' = \case
30p_valDecl' = \case
31 FunBind NoExt funId funMatches _ _ -> p_funBind funId funMatches
31 FunBind NoExt funId funMatches _ _ -> p_funBind funId funMatches
32 PatBind NoExt pat grhss _ -> p_match PatternBind [pat] grhss
32 PatBind NoExt pat grhss _ -> p_match PatternBind [pat] grhss
33− VarBind {} -> error "VarBinds are introduced by the type checker"
33+ VarBind {} -> notImplemented "VarBinds" -- introduced by the type checker
34− AbsBinds {} -> error "AbsBinds are introduced by the type checker"
34+ AbsBinds {} -> notImplemented "AbsBinds" -- introduced by the type checker
35 PatSynBind NoExt psb -> p_patSynBind psb
35 PatSynBind NoExt psb -> p_patSynBind psb
36 XHsBindsLR NoExt -> notImplemented "XHsBindsLR"
36 XHsBindsLR NoExt -> notImplemented "XHsBindsLR"
37
37
@@ -104,18 +104,23 @@ p_match style m_pats m_grhss = do
104 _ -> "->"
104 _ -> "->"
105 let combinedSpans = combineSrcSpans' $
105 let combinedSpans = combineSrcSpans' $
106 getGRHSSpan . unL <$> NE.fromList grhssGRHSs
106 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)
107 case style of
117 case style of
118+ Lambda -> do
108− Lambda -> breakpoint
119+ breakpoint'
109− _ -> return ()
120+ switchLayout combinedSpans p_body
110− switchLayout combinedSpans . inci $ do
121+ _ -> switchLayout combinedSpans . inci $ do
111− case style of
112− Lambda -> return ()
113− _ -> breakpoint
122+ breakpoint'
114− newlineSep (located' (p_grhs Guard)) grhssGRHSs
123+ p_body
115− unless (GHC.isEmptyLocalBindsPR (unL grhssLocalBinds)) $ do
116− newline
117− line (txt "where")
118− inci (located grhssLocalBinds p_hsLocalBinds)
119
124
120data GroupStyle
125data GroupStyle
121 = Guard
126 = Guard
@@ -140,11 +145,19 @@ p_grhs _ (XGRHS NoExt) = notImplemented "XGRHS"
140
145
141p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
146p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
142p_stmt = \case
147p_stmt = \case
143− LastStmt {} -> notImplemented "do notation"
148+ LastStmt NoExt _ _ _ ->
144− BindStmt {} -> notImplemented "do notation"
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)
145− ApplicativeStmt {} -> notImplemented "applicative stmt"
156+ ApplicativeStmt {} -> notImplemented "ApplicativeStmt"
146 BodyStmt NoExt body _ _ -> located body p_hsExpr
157 BodyStmt NoExt body _ _ -> located body p_hsExpr
158+ LetStmt NoExt binds -> do
159+ txt "let "
147− LetStmt NoExt binds -> located binds p_hsLocalBinds
160+ sitcc $ located binds p_hsLocalBinds
148 ParStmt {} -> notImplemented "ParStmt"
161 ParStmt {} -> notImplemented "ParStmt"
149 TransStmt {} -> notImplemented "TransStmt"
162 TransStmt {} -> notImplemented "TransStmt"
150 RecStmt {} -> notImplemented "RecStmt"
163 RecStmt {} -> notImplemented "RecStmt"
@@ -203,7 +216,7 @@ p_hsExpr = \case
203 HsLamCase NoExt mgroup -> do
216 HsLamCase NoExt mgroup -> do
204 txt "\\case"
217 txt "\\case"
205 newline
218 newline
206− inci (p_matchGroup LambdaCase mgroup)
219+ p_matchGroup LambdaCase mgroup
207 HsApp NoExt f x -> do
220 HsApp NoExt f x -> do
208 located f p_hsExpr
221 located f p_hsExpr
209 breakpoint
222 breakpoint
@@ -287,7 +300,13 @@ p_hsExpr = \case
287 breakpoint
300 breakpoint
288 txt "in "
301 txt "in "
289 sitcc (located e p_hsExpr)
302 sitcc (located e p_hsExpr)
303+ HsDo NoExt ctx es -> do
304+ case ctx of
305+ DoExpr -> txt "do"
306+ MDoExpr -> txt "mdo"
290− HsDo {} -> notImplemented "HsDo"
307+ _ -> notImplemented "certain kinds of do notation"
308+ newline
309+ located es (newlineSep (located' p_stmt))
291 ExplicitList _ _ xs -> do
310 ExplicitList _ _ xs -> do
292 brackets $ velt (withSep comma (located' p_hsExpr) xs)
311 brackets $ velt (withSep comma (located' p_hsExpr) xs)
293 RecordCon {..} -> do
312 RecordCon {..} -> do
@@ -411,3 +430,17 @@ p_patSynDetails = \case
411getGRHSSpan :: GRHS GhcPs (LHsExpr GhcPs) -> SrcSpan
430getGRHSSpan :: GRHS GhcPs (LHsExpr GhcPs) -> SrcSpan
412getGRHSSpan (GRHS NoExt _ body) = getSpan body
431getGRHSSpan (GRHS NoExt _ body) = getSpan body
413getGRHSSpan (XGRHS NoExt) = notImplemented "XGRHS"
432getGRHSSpan (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