google/ormolu
1
1
Fork 0
mirror of https://github.com/google/ormolu.git synced 2024-11-27 03:24:10 +03:00
Code Issues Projects Releases Wiki Activity

Hang expressions in RHS of (<-) in do blocks

Browse Source 
Plus some refactoring.
This commit is contained in:
mrkkrp 2019-10-03 15:21:10 +02:00 committed by Mark Karpov
parent 519136f062
commit 368b2da09b
7 changed files with 129 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
data/examples/declaration/value/function/arrow/proc-do-complex-out.hs
View File

@ -24,8 +24,7 @@ foo
d * b
)
if x `mod` y == 0 -- Basic condition
then
case e of -- Only left case is relevant
then case e of -- Only left case is relevant
Left
( z,
w
@ -33,28 +32,25 @@ foo
let v =
u -- Actually never used
^ 2
in ( returnA -<
-- Just do the calculation
(x + y * z)
)
else
do
else do
let u = x -- Let bindings bind expressions, not commands
-- Could pattern match directly on x
i <-
case u of
0 -> (g . h -< u)
n ->
( ( h . g -<
y -- First actual use of y
)
i <- case u of
0 -> (g . h -< u)
n ->
( ( h . g -<
y -- First actual use of y
)
)
returnA -< ()
-- Sometimes execute effects
if i > 0
then ma -< ()
else returnA -< ()
then ma -< ()
else returnA -< ()
returnA -<
( i
+ x

14
data/examples/declaration/value/function/arrow/proc-ifs-out.hs
View File

@ -4,10 +4,10 @@ foo f = proc a -> if a then f -< 0 else f -< 1
bar f g = proc a ->
if f a
then
f
. g -<
a
else
g -<
b
then
f
. g -<
a
else
g -<
b

1
data/examples/declaration/value/function/arrow/proc-lets-out.hs
View File

@ -9,5 +9,4 @@ bar f g = proc a ->
j =
g
. h
in id -< (h, j)

1
data/examples/declaration/value/function/do/expr.hs
View File

@ -8,4 +8,3 @@ quux = something $ do
then x
else y
baz

9
data/examples/declaration/value/function/do/hang-rhs-arrow-out.hs Normal file
View File

@ -0,0 +1,9 @@
foo = do
something <- case bar of
Foo -> return 1
Bar -> return 2
somethingElse <-
case boom of
Foo -> return 1
Bar -> return 2
quux something somethingElse

9
data/examples/declaration/value/function/do/hang-rhs-arrow.hs Normal file
View File

@ -0,0 +1,9 @@
foo = do
something <- case bar of
Foo -> return 1
Bar -> return 2
somethingElse <-
case boom of
Foo -> return 1
Bar -> return 2
quux something somethingElse

172
src/Ormolu/Printer/Meat/Declaration/Value.hs
View File

@ -91,7 +91,7 @@ p_matchGroup'
-> MatchGroupStyle -- ^ Style of this group of equations
-> MatchGroup GhcPs (Located body) -- ^ Match group
-> R ()
p_matchGroup' placer pretty style MG {..} = do
p_matchGroup' placer render style MG {..} = do
let ob = case style of
Case -> id
LambdaCase -> id
@ -104,7 +104,7 @@ p_matchGroup' placer pretty style MG {..} = do
p_Match m@Match {..} =
p_match'
placer
pretty
render
(adjustMatchGroupStyle m style)
(isInfixMatch m)
(matchStrictness m)
@ -153,7 +153,7 @@ p_match'
-> [LPat GhcPs] -- ^ Argument patterns
-> GRHSs GhcPs (Located body) -- ^ Equations
-> R ()
p_match' placer pretty style isInfix strictness m_pats m_grhss = do
p_match' placer render style isInfix strictness m_pats m_grhss = do
-- NOTE Normally, since patterns may be placed in a multi-line layout, it
-- is necessary to bump indentation for the pattern group so it's more
-- indented than function name. This in turn means that indentation for
@ -235,7 +235,7 @@ p_match' placer pretty style isInfix strictness m_pats m_grhss = do
if isCase style && hasGuards
then RightArrow
else EqualSign
sep newline (located' (p_grhs' placer pretty groupStyle)) grhssGRHSs
sep newline (located' (p_grhs' placer render groupStyle)) grhssGRHSs
p_where = do
let whereIsEmpty = GHC.isEmptyLocalBindsPR (unLoc grhssLocalBinds)
unless (GHC.eqEmptyLocalBinds (unLoc grhssLocalBinds)) $ do
@ -258,7 +258,7 @@ p_grhs'
-> GroupStyle
-> GRHS GhcPs (Located body)
-> R ()
p_grhs' placer pretty style (GRHS NoExt guards body) =
p_grhs' placer render style (GRHS NoExt guards body) =
case guards of
[] -> p_body
xs -> do
@ -282,7 +282,7 @@ p_grhs' placer pretty style (GRHS NoExt guards body) =
case NE.nonEmpty guards of
Nothing -> Nothing
Just gs -> (Just . srcSpanEnd . getLoc . NE.last) gs
p_body = located body pretty
p_body = located body render
p_grhs' _ _ _ (XGRHS NoExt) = notImplemented "XGRHS"
p_hsCmd :: HsCmd GhcPs -> R ()
@ -313,41 +313,17 @@ p_hsCmd = \case
notImplemented "HsCmdApp"
HsCmdLam NoExt mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup
HsCmdPar NoExt c -> parens N (located c p_hsCmd)
HsCmdCase NoExt e mgroup -> do
txt "case"
space
located e p_hsExpr
space
txt "of"
breakpoint
inci (p_matchGroup' cmdPlacement p_hsCmd Case mgroup)
HsCmdIf NoExt _ if' then' else' -> do
txt "if"
space
located if' p_hsExpr
breakpoint
txt "then"
located then' $ \x -> do
breakpoint
inci (p_hsCmd x)
breakpoint
txt "else"
located else' $ \x -> do
breakpoint
inci (p_hsCmd x)
HsCmdLet NoExt localBinds c -> do
txt "let"
space
sitcc (located localBinds p_hsLocalBinds)
breakpoint
vlayout space (newline >> txt " ")
txt "in"
space
sitcc (located c p_hsCmd)
HsCmdCase NoExt e mgroup ->
p_case cmdPlacement p_hsCmd e mgroup
HsCmdIf NoExt _ if' then' else' ->
p_if cmdPlacement p_hsCmd if' then' else'
HsCmdLet NoExt localBinds c ->
p_let p_hsCmd localBinds c
HsCmdDo NoExt es -> do
txt "do"
newline
inci (located es (sitcc . sep newline (located' (sitcc . p_stmt' p_hsCmd))))
inci . located es $
sitcc . sep newline (located' (sitcc . p_stmt' cmdPlacement p_hsCmd))
HsCmdWrap {} -> notImplemented "HsCmdWrap"
XCmd {} -> notImplemented "XCmd"
@ -357,23 +333,31 @@ p_hsCmdTop = \case
XCmdTop {} -> notImplemented "XHsCmdTop"
p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
p_stmt = p_stmt' p_hsExpr
p_stmt = p_stmt' exprPlacement p_hsExpr
p_stmt'
:: Data body
=> (body -> R ())
-> Stmt GhcPs (Located body)
=> (body -> Placement) -- ^ Placer
-> (body -> R ()) -- ^ Render
-> Stmt GhcPs (Located body) -- ^ Statement to render
-> R ()
p_stmt' pretty = \case
LastStmt NoExt body _ _ -> located body pretty
p_stmt' placer render = \case
LastStmt NoExt body _ _ -> located body render
BindStmt NoExt l f _ _ -> do
located l p_pat
space
txt "<-"
breakpoint
inci (located f pretty)
let placement =
case f of
L l' x ->
if isOneLineSpan
(mkSrcSpan (srcSpanEnd (getLoc l)) (srcSpanStart l'))
then placer x
else Normal
switchLayout [getLoc l, getLoc f] $
placeHanging placement (located f render)
ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer
BodyStmt NoExt body _ _ -> located body pretty
BodyStmt NoExt body _ _ -> located body render
LetStmt NoExt binds -> do
txt "let"
space
@ -384,7 +368,7 @@ p_stmt' pretty = \case
-- here would be redundant.
notImplemented "ParStmt"
TransStmt {..} -> do
-- NOTE 'TransStmt' only needs to account for pretty printing itself,
-- NOTE 'TransStmt' only needs to account for render printing itself,
-- since pretty printing of relevant statements (e.g., in 'trS_stmts')
-- is handled through 'gatherStmt'.
case (trS_form, trS_by) of
@ -415,7 +399,7 @@ p_stmt' pretty = \case
RecStmt {..} -> do
txt "rec"
space
sitcc $ sepSemi (located' (p_stmt' pretty)) recS_stmts
sitcc $ sepSemi (located' (p_stmt' placer render)) recS_stmts
XStmtLR {} -> notImplemented "XStmtLR"
gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]
@ -581,45 +565,24 @@ p_hsExpr' s = \case
sep (comma >> breakpoint) (sitcc . located' p_hsTupArg) args
ExplicitSum NoExt tag arity e ->
p_unboxedSum N tag arity (located e p_hsExpr)
HsCase NoExt e mgroup -> do
txt "case"
space
located e p_hsExpr
space
txt "of"
breakpoint
inci (p_matchGroup Case mgroup)
HsIf NoExt _ if' then' else' -> do
txt "if"
space
located if' p_hsExpr
breakpoint
inci $ do
txt "then"
located then' $ \x ->
placeHanging (exprPlacement x) (p_hsExpr x)
breakpoint
txt "else"
located else' $ \x ->
placeHanging (exprPlacement x) (p_hsExpr x)
HsCase NoExt e mgroup ->
p_case exprPlacement p_hsExpr e mgroup
HsIf NoExt _ if' then' else' ->
p_if exprPlacement p_hsExpr if' then' else'
HsMultiIf NoExt guards -> do
txt "if"
breakpoint
inci . sitcc $ sep newline (located' (p_grhs RightArrow)) guards
HsLet NoExt localBinds e -> sitcc $ do
txt "let"
space
dontUseBraces $ sitcc (located localBinds p_hsLocalBinds)
vlayout space (newline >> txt " ")
txt "in"
space
sitcc (located e p_hsExpr)
HsLet NoExt localBinds e ->
p_let p_hsExpr localBinds e
HsDo NoExt ctx es -> do
let doBody header = do
txt header
breakpoint
ub <- layoutToBraces <$> getLayout
inci $ sepSemi (located' (ub . p_stmt' (p_hsExpr' S))) (unLoc es)
inci $ sepSemi
(located' (ub . p_stmt' exprPlacement (p_hsExpr' S)))
(unLoc es)
compBody = brackets N $ located es $ \xs -> do
let p_parBody = sep
(breakpoint >> txt "| ")
@ -816,6 +779,59 @@ p_patSynBind PSB {..} = do
inci rhs
p_patSynBind (XPatSynBind NoExt) = notImplemented "XPatSynBind"
p_case
:: Data body
=> (body -> Placement) -- ^ Placer
-> (body -> R ()) -- ^ Render
-> LHsExpr GhcPs -- ^ Expression
-> (MatchGroup GhcPs (Located body)) -- ^ Match group
-> R ()
p_case placer render e mgroup = do
txt "case"
space
located e p_hsExpr
space
txt "of"
breakpoint
inci (p_matchGroup' placer render Case mgroup)
p_if
:: Data body
=> (body -> Placement) -- ^ Placer
-> (body -> R ()) -- ^ Render
-> LHsExpr GhcPs -- ^ If
-> Located body -- ^ Then
-> Located body -- ^ Else
-> R ()
p_if placer render if' then' else' = do
txt "if"
space
located if' p_hsExpr
breakpoint
inci $ do
txt "then"
located then' $ \x ->
placeHanging (placer x) (render x)
breakpoint
txt "else"
located else' $ \x ->
placeHanging (placer x) (render x)
p_let
:: Data body
=> (body -> R ()) -- ^ Render
-> Located (HsLocalBindsLR GhcPs GhcPs)
-> Located body
-> R ()
p_let render localBinds e = sitcc $ do
txt "let"
space
dontUseBraces $ sitcc (located localBinds p_hsLocalBinds)
vlayout space (newline >> txt " ")
txt "in"
space
sitcc (located e render)
p_pat :: Pat GhcPs -> R ()
p_pat = \case
WildPat NoExt -> txt "_"