git.iko.soy/ormolu
on master help sign in
Implement all facets of arrow notation
1654ac1yumiova
data/examples/declaration/value/function/arrow/expression-applications-out.hsnew file+8
compare with master
unifiedsplit
@@ -0,0 +1,8 @@
1+{-# LANGUAGE Arrows #-}
2+foo x y = x -< y
3+
4+bar f x =
5+ f x -< -- Hello
6+ x -- World
7+
8+baz x y = x -<< y
data/examples/declaration/value/function/arrow/expression-applications.hsnew file+9
@@ -0,0 +1,9 @@
1+{-# LANGUAGE Arrows #-}
2+
3+foo x y = x -< y
4+
5+bar f x
6+ = f x -- Hello
7+ -< x -- World
8+
9+baz x y = x -<< y
data/examples/declaration/value/function/arrow/expression-forms-out.hsnew file+12
@@ -0,0 +1,12 @@
1+{-# LANGUAGE Arrows #-}
2+foo f g x y = (|test (f -< x) (g -< y)|)
3+
4+bar f g x y =
5+ (| test
6+ ( f -<
7+ x
8+ )
9+ ( g -<
10+ y
11+ )
12+ |)
data/examples/declaration/value/function/arrow/expression-forms.hsnew file+11
@@ -0,0 +1,11 @@
1+{-# LANGUAGE Arrows #-}
2+
3+foo f g x y = (| test (f -< x) (g -< y) |)
4+
5+bar f g x y = (|
6+ test
7+ (f
8+ -< x)
9+ (g
10+ -< y)
11+ |)
data/examples/declaration/value/function/arrow/proc-applications-out.hsnew file+17
@@ -0,0 +1,17 @@
1+{-# LANGUAGE Arrows #-}
2+foo x = proc a -> a -< x
3+
4+bar f x =
5+ proc
6+ ( y
7+ , z
8+ , w
9+ )
10+ ->
11+ f -< -- The value
12+ ( x -- Foo
13+ , w -- Bar
14+ , z -- Baz
15+ )
16+
17+baz x = proc a -> a -<< x
data/examples/declaration/value/function/arrow/proc-applications.hsnew file+17
@@ -0,0 +1,17 @@
1+{-# LANGUAGE Arrows #-}
2+
3+foo x = proc a -> a -< x
4+
5+bar f x =
6+ proc (
7+ y,
8+ z,
9+ w
10+ ) -> f -- The value
11+ -< (
12+ x, -- Foo
13+ w, -- Bar
14+ z -- Baz
15+ )
16+
17+baz x = proc a -> a -<< x
data/examples/declaration/value/function/arrow/proc-cases-out.hsnew file+14
@@ -0,0 +1,14 @@
1+{-# LANGUAGE Arrows #-}
2+foo f = proc a -> case a of Left b -> f -< b
3+
4+bar f g h j = proc a -> case a of
5+ Left
6+ ( (a, b)
7+ , (c, d)
8+ ) -> f (a <> c) -< b <> d
9+ Right
10+ (Left a) ->
11+ h -< a
12+ Right
13+ (Right b) ->
14+ j -< b
data/examples/declaration/value/function/arrow/proc-cases.hsnew file+17
@@ -0,0 +1,17 @@
1+{-# LANGUAGE Arrows #-}
2+foo f =proc a -> case a of Left b -> f -<b
3+
4+bar f g h j
5+ = proc a ->
6+ case a of
7+ Left (
8+ (a, b),
9+ (c, d)
10+ ) -> f (a <> c) -< b <> d
11+
12+ Right
13+ (Left a) ->
14+ h -< a
15+ Right
16+ (Right b) ->
17+ j -< b
data/examples/declaration/value/function/arrow/proc-do-complex-out.hsnew file+60
@@ -0,0 +1,60 @@
1+{-# LANGUAGE Arrows #-}
2+foo
3+ f
4+ g
5+ h
6+ ma =
7+ proc
8+ ( (a, b)
9+ , (c, d)
10+ , (e, f)
11+ )
12+ -> do
13+ -- Begin do
14+ (x, y) <- -- GHC parser fails if layed out over multiple lines
15+ f -- Call into f
16+ ( a
17+ , c -- Tuple together arguments
18+ )
19+ ( b
20+ , d
21+ ) -<
22+ ( b + 1 -- Funnel into arrow
23+ , d * b
24+ )
25+ if x `mod` y == 0 -- Basic condition
26+ then
27+ case e of -- Only left case is relevant
28+ Left
29+ ( z
30+ , w
31+ ) -> \u -> -- Procs can have lambdas
32+ let v =
33+ u ^ -- Actually never used
34+ 2
35+ in ( returnA -<
36+ -- Just do the calculation
37+ (x + y * z)
38+ )
39+ else
40+ do
41+ let u = x -- Let bindings bind expressions, not commands
42+ -- Could pattern match directly on x
43+ i <-
44+ case u of
45+ 0 -> (g . h -< u)
46+ n ->
47+ ( ( h . g -<
48+ y -- First actual use of y
49+ )
50+ )
51+ returnA -< ()
52+ -- Sometimes execute effects
53+ if i > 0
54+ then ma -< ()
55+ else returnA -< ()
56+ returnA -<
57+ ( i +
58+ x *
59+ y -- Just do the calculation
60+ )
data/examples/declaration/value/function/arrow/proc-do-complex.hsnew file+49
@@ -0,0 +1,49 @@
1+{-# LANGUAGE Arrows #-}
2+foo
3+ f
4+ g
5+ h
6+ ma = proc (
7+ (a, b),
8+ (c, d),
9+ (e, f)
10+ ) ->
11+ do -- Begin do
12+ (x,y) -- GHC parser fails if layed out over multiple lines
13+ <- f -- Call into f
14+ (a,
15+ c) -- Tuple together arguments
16+ (b,
17+ d)
18+ -< (b + 1, -- Funnel into arrow
19+ d * b)
20+ if
21+ x `mod` y == 0 -- Basic condition
22+ then case e -- Only left case is relevant
23+ of Left (z,
24+ w) -> \u -> -- Procs can have lambdas
25+ let
26+ v
27+ = u -- Actually never used
28+ ^ 2
29+ in
30+ (returnA
31+ -< -- Just do the calculation
32+ (x + y * z))
33+ else do
34+ let u = x -- Let bindings bind expressions, not commands
35+ -- Could pattern match directly on x
36+ i <- case u of
37+ 0 -> (g . h -< u)
38+ n -> (
39+ (h . g
40+ -< y) -- First actual use of y
41+ )
42+ returnA -< ()
43+ -- Sometimes execute effects
44+ if i > 0
45+ then ma -< ()
46+ else returnA -< ()
47+ returnA -< (i +
48+ x *
49+ y) -- Just do the calculation
data/examples/declaration/value/function/arrow/proc-do-simple-out.hsnew file+35
@@ -0,0 +1,35 @@
1+{-# LANGUAGE Arrows #-}
2+foo f = proc a -> do
3+ f -< a
4+
5+bar f = proc a -> do
6+ b <- f -< a
7+
8+barbar f g = proc a -> do
9+ b <- f -< a
10+ returnA -< b
11+
12+barbaz f g = proc (a, b) -> do
13+ c <- f -< a
14+ d <- g -< b
15+
16+bazbar f = proc a -> do
17+ a <-
18+ f -<
19+ a
20+
21+bazbaz f g h = proc (a, b, c) -> do
22+ x <-
23+ f b -< a
24+ y <-
25+ g b -< b
26+ z <-
27+ h
28+ x
29+ y -<
30+ ( a
31+ , b
32+ , c
33+ )
34+ returnA -<
35+ (x, y, z)
data/examples/declaration/value/function/arrow/proc-do-simple.hsnew file+39
@@ -0,0 +1,39 @@
1+{-# LANGUAGE Arrows #-}
2+
3+foo f = proc a ->
4+ do f -< a
5+
6+bar f = proc a ->
7+ do b <- f -< a
8+
9+barbar f g = proc a ->
10+ do b <- f -< a
11+ returnA -< b
12+
13+barbaz f g = proc (a, b) ->
14+ do c <- f -< a
15+ d <- g -< b
16+
17+bazbar f = proc a ->
18+ do a
19+ <-
20+ f
21+ -<
22+ a
23+
24+bazbaz f g h = proc (a, b, c) ->
25+ do x
26+ <- f b -< a
27+ y <-
28+ g b -< b
29+ z <-
30+ h
31+ x
32+ y
33+ -< (
34+ a,
35+ b,
36+ c
37+ )
38+ returnA -<
39+ (x, y, z)
data/examples/declaration/value/function/arrow/proc-forms-out.hsnew file+30
@@ -0,0 +1,30 @@
1+{-# LANGUAGE Arrows #-}
2+foo0 f g x y = proc _ -> (|f (g -< (x, y))|)
3+
4+foo1 f g h x = proc (y, z) ->
5+ (|test (h f . (h g) -< (y x) . y z) ((h g) . h f -< y z . (y x))|)
6+
7+foo2 f g h x = proc (y, z) ->
8+ (| test
9+ ( h f .
10+ h g -<
11+ y x .
12+ y z
13+ )
14+ ( h g .
15+ h f -<
16+ y z .
17+ y x
18+ )
19+ |)
20+
21+bar0 f g x y = proc _ -> f -< x &&& g -< y
22+
23+bar1 f g h x = proc (y, z) ->
24+ h f . (h g) -< (y x) . y z ||| (h g) . h f -< y z . (y x)
25+
26+bar2 f g h x = proc (y, z) ->
27+ (h f . h g) -<
28+ (y x) . y z |||
29+ (h g . h f) -<
30+ y z . (y x)
data/examples/declaration/value/function/arrow/proc-forms.hsnew file+36
@@ -0,0 +1,36 @@
1+{-# LANGUAGE Arrows #-}
2+
3+foo0 f g x y = proc _ -> (| f (g -< (x, y)) |)
4+
5+foo1 f g h x =
6+ proc (y, z) ->
7+ (| test (h f.(h g) -< (y x).y z)((h g) . h f-<y z . (y x)) |)
8+
9+foo2 f g h x =
10+ proc (y, z) -> (|
11+ test ( h f
12+ . h g
13+ -<
14+ y x
15+ . y z
16+ )
17+ ( h g
18+ . h f
19+ -<
20+ y z
21+ . y x)
22+ |)
23+
24+bar0 f g x y = proc _ -> f -< x&&&g -< y
25+
26+bar1 f g h x =
27+ proc (y, z) ->
28+ h f.(h g) -< (y x).y z ||| (h g) . h f-<y z . (y x)
29+
30+bar2 f g h x =
31+ proc (y, z) ->
32+ (h f.h g)
33+ -< (y x).y z
34+ |||
35+ (h g . h f)
36+ -<y z . (y x)
data/examples/declaration/value/function/arrow/proc-ifs-out.hsnew file+12
@@ -0,0 +1,12 @@
1+{-# LANGUAGE Arrows #-}
2+foo f = proc a -> if a then f -< 0 else f -< 1
3+
4+bar f g = proc a ->
5+ if f a
6+ then
7+ f .
8+ g -<
9+ a
10+ else
11+ g -<
12+ b
data/examples/declaration/value/function/arrow/proc-ifs.hsnew file+14
@@ -0,0 +1,14 @@
1+{-# LANGUAGE Arrows #-}
2+
3+foo f = proc a -> if a then f-<0 else f-<1
4+
5+bar f g = proc a ->
6+ if
7+ f a
8+ then
9+ f
10+ . g -< a
11+ else
12+ g
13+ -<
14+ b
data/examples/declaration/value/function/arrow/proc-lambdas-out.hsnew file+5
@@ -0,0 +1,5 @@
1+{-# LANGUAGE Arrows #-}
2+foo = proc a -> \f b -> a -< f b -- Foo
3+
4+bar = proc x -> \f g h -> \() -> \(Left (x, y)) -> -- Tuple value
5+ f (g (h x)) -< y
data/examples/declaration/value/function/arrow/proc-lambdas.hsnew file+10
@@ -0,0 +1,10 @@
1+{-# LANGUAGE Arrows #-}
2+
3+foo = proc a-> \f b->a-<f b -- Foo
4+
5+bar =
6+ proc x ->
7+ \f g h ->
8+ \() ->
9+ \( Left (x,y )) -> -- Tuple value
10+ f (g (h x)) -< y
data/examples/declaration/value/function/arrow/proc-lets-out.hsnew file+11
@@ -0,0 +1,11 @@
1+{-# LANGUAGE Arrows #-}
2+foo f = proc a -> let b = a in f -< b
3+
4+bar f g = proc a ->
5+ let h =
6+ f .
7+ g a
8+ j =
9+ g .
10+ h
11+ in id -< (h, j)
data/examples/declaration/value/function/arrow/proc-lets.hsnew file+14
@@ -0,0 +1,14 @@
1+{-# LANGUAGE Arrows #-}
2+
3+foo f = proc a -> let b = a in f -< b
4+
5+bar f g = proc a ->
6+ let
7+ h
8+ = f
9+ . g a
10+ j = g
11+ .
12+ h
13+ in
14+ id -< (h, j)
data/examples/declaration/value/function/arrow/proc-parentheses-out.hsnew file+17
@@ -0,0 +1,17 @@
1+{-# LANGUAGE Arrows #-}
2+foo f = proc a -> (f -< a)
3+
4+bar f g = proc a ->
5+ ( ( (f)
6+ ( g
7+ )
8+ ) -<
9+ ( ( ( ( ( ( g
10+ a
11+ )
12+ )
13+ )
14+ )
15+ )
16+ )
17+ )
data/examples/declaration/value/function/arrow/proc-parentheses.hsnew file+12
@@ -0,0 +1,12 @@
1+{-# LANGUAGE Arrows #-}
2+foo f = proc a -> ( f -< a )
3+
4+bar f g = proc a ->
5+ ( ((f) (
6+ g
7+ ))
8+ -< (((((
9+ (g
10+ a)
11+ )))))
12+ )
data/examples/declaration/value/function/arrow/recursive-procs-out.hsnew file+18
@@ -0,0 +1,18 @@
1+{-# LANGUAGE Arrows #-}
2+foo f g = proc (x, y) -> do
3+ rec a <- f y -< x
4+ b <-
5+ g x -<
6+ y
7+ bar -<
8+ ( a
9+ , b
10+ )
11+ rec p <-
12+ f
13+ p -<
14+ a
15+ rec q <-
16+ g
17+ q -<
18+ b
data/examples/declaration/value/function/arrow/recursive-procs.hsnew file+18
@@ -0,0 +1,18 @@
1+{-# LANGUAGE Arrows #-}
2+
3+foo f g = proc (x, y) -> do
4+ rec
5+ a <- f y -< x
6+ b
7+ <-
8+ g x
9+ -<
10+ y
11+ bar -< (
12+ a,
13+ b
14+ )
15+ rec p <- f
16+ p -< a
17+ rec q <- g
18+ q-< b
data/examples/declaration/value/function/do-out.hs+13
@@ -32,3 +32,16 @@ quux =
32 then x
32 then x
33 else y
33 else y
34 baz
34 baz
35+
36+foo = do
37+ rec a <- b + 5
38+ let d = c
39+ b <- a * 5
40+ something
41+ c <- a + b
42+ print c
43+ rec something $ do
44+ x <- a
45+ print x
46+ y <- c
47+ print y
data/examples/declaration/value/function/do.hs+19
@@ -27,3 +27,22 @@ quux = something $ do
27 then x
27 then x
28 else y
28 else y
29 baz
29 baz
30+
31+foo = do
32+ rec
33+ a <- b + 5
34+
35+ let d = c
36+
37+ b <- a * 5
38+
39+ something
40+
41+ c <- a + b
42+ print c
43+ rec something $ do
44+ x <- a
45+ print x
46+
47+ y <- c
48+ print y
src/Ormolu/Printer/Combinators.hs+9
@@ -33,6 +33,7 @@ module Ormolu.Printer.Combinators
33 , sitcc
33 , sitcc
34 , line
34 , line
35 , backticks
35 , backticks
36+ , banana
36 , braces
37 , braces
37 , brackets
38 , brackets
38 , bracketsPar
39 , bracketsPar
@@ -228,6 +229,14 @@ backticks m = do
228 m
229 m
229 txt "`"
230 txt "`"
230
231
232+-- | Surround given entity by banana brackets (i.e., from arrow notation.)
233+
234+banana :: R () -> R ()
235+banana m = sitcc $ do
236+ txt "(|"
237+ ospaces m
238+ txt "|)"
239+
231-- | Surround given entity by curly braces @{@ and @}@.
240-- | Surround given entity by curly braces @{@ and @}@.
232
241
233braces :: R () -> R ()
242braces :: R () -> R ()
src/Ormolu/Printer/Meat/Declaration/Value.hs+157−24
@@ -13,7 +13,7 @@ where
13import Bag (bagToList)
13import Bag (bagToList)
14import BasicTypes
14import BasicTypes
15import Control.Monad
15import Control.Monad
16−import Data.Data
16+import Data.Data hiding (Infix, Prefix)
17import Data.List (intersperse, sortOn)
17import Data.List (intersperse, sortOn)
18import Data.Text (Text)
18import Data.Text (Text)
19import GHC
19import GHC
@@ -72,11 +72,20 @@ p_matchGroup
72 :: MatchGroupStyle
72 :: MatchGroupStyle
73 -> MatchGroup GhcPs (LHsExpr GhcPs)
73 -> MatchGroup GhcPs (LHsExpr GhcPs)
74 -> R ()
74 -> R ()
75−p_matchGroup style MG {..} =
75+p_matchGroup = p_matchGroup' exprPlacement p_hsExpr
76+
77+p_matchGroup'
78+ :: Data body
79+ => (body -> Placement)
80+ -> (body -> R ())
81+ -> MatchGroupStyle
82+ -> MatchGroup GhcPs (Located body)
83+ -> R ()
84+p_matchGroup' placer pretty style MG {..} =
76 locatedVia Nothing mg_alts $
85 locatedVia Nothing mg_alts $
77 newlineSep (located' (\m@Match {..} ->
86 newlineSep (located' (\m@Match {..} ->
78− p_match style (isInfixMatch m) m_pats m_grhss))
87+ p_match' placer pretty style (isInfixMatch m) m_pats m_grhss))
79−p_matchGroup _ (XMatchGroup NoExt) = notImplemented "XMatchGroup"
88+p_matchGroup' _ _ _ (XMatchGroup NoExt) = notImplemented "XMatchGroup"
80
89
81p_match
90p_match
82 :: MatchGroupStyle
91 :: MatchGroupStyle
@@ -84,7 +93,18 @@ p_match
84 -> [LPat GhcPs]
93 -> [LPat GhcPs]
85 -> GRHSs GhcPs (LHsExpr GhcPs)
94 -> GRHSs GhcPs (LHsExpr GhcPs)
86 -> R ()
95 -> R ()
96+p_match = p_match' exprPlacement p_hsExpr
97+
98+p_match'
99+ :: Data body
100+ => (body -> Placement)
101+ -> (body -> R ())
102+ -> MatchGroupStyle
103+ -> Bool -- ^ Is this an infix match?
104+ -> [LPat GhcPs]
105+ -> GRHSs GhcPs (Located body)
106+ -> R ()
87−p_match style isInfix m_pats m_grhss = do
107+p_match' placer pretty style isInfix m_pats m_grhss = do
88 -- NOTE Normally, since patterns may be placed in a multi-line layout, it
108 -- NOTE Normally, since patterns may be placed in a multi-line layout, it
89 -- is necessary to bump indentation for the pattern group so it's more
109 -- is necessary to bump indentation for the pattern group so it's more
90 -- indented than function name. This in turn means that indentation for
110 -- indented than function name. This in turn means that indentation for
@@ -144,7 +164,7 @@ p_match style isInfix m_pats m_grhss = do
144 let grhssSpan = combineSrcSpans' $
164 let grhssSpan = combineSrcSpans' $
145 getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs
165 getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs
146 patGrhssSpan = maybe grhssSpan (combineSrcSpans grhssSpan) endOfPatsSpan
166 patGrhssSpan = maybe grhssSpan (combineSrcSpans grhssSpan) endOfPatsSpan
147− placement = blockPlacement grhssGRHSs
167+ placement = blockPlacement placer grhssGRHSs
148 inciLocalBinds = case placement of
168 inciLocalBinds = case placement of
149 Normal -> id
169 Normal -> id
150 Hanging -> inci
170 Hanging -> inci
@@ -153,7 +173,7 @@ p_match style isInfix m_pats m_grhss = do
153 if isCase style && hasGuards
173 if isCase style && hasGuards
154 then RightArrow
174 then RightArrow
155 else EqualSign
175 else EqualSign
156− newlineSep (located' (p_grhs groupStyle)) grhssGRHSs
176+ newlineSep (located' (p_grhs' pretty groupStyle)) grhssGRHSs
157 unless
177 unless
158 (GHC.isEmptyLocalBindsPR (unLoc grhssLocalBinds))
178 (GHC.isEmptyLocalBindsPR (unLoc grhssLocalBinds))
159 (inciLocalBinds $ do
179 (inciLocalBinds $ do
@@ -168,7 +188,15 @@ p_match style isInfix m_pats m_grhss = do
168 placeHanging placement p_body
188 placeHanging placement p_body
169
189
170p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R ()
190p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R ()
191+p_grhs = p_grhs' p_hsExpr
192+
193+p_grhs'
194+ :: Data body
195+ => (body -> R ())
196+ -> GroupStyle
197+ -> GRHS GhcPs (Located body)
198+ -> R ()
171−p_grhs style (GRHS NoExt guards body) =
199+p_grhs' pretty style (GRHS NoExt guards body) =
172 case guards of
200 case guards of
173 [] -> p_body
201 [] -> p_body
174 xs -> do
202 xs -> do
@@ -181,20 +209,91 @@ p_grhs style (GRHS NoExt guards body) =
181 breakpoint
209 breakpoint
182 inci p_body
210 inci p_body
183 where
211 where
184− p_body = located body p_hsExpr
212+ p_body = located body pretty
185−p_grhs _ (XGRHS NoExt) = notImplemented "XGRHS"
213+p_grhs' _ _ (XGRHS NoExt) = notImplemented "XGRHS"
214+
215+p_hsCmd :: HsCmd GhcPs -> R ()
216+p_hsCmd = \case
217+ HsCmdArrApp NoExt body input arrType _ -> do
218+ located body p_hsExpr
219+ txt $ case arrType of
220+ HsFirstOrderApp -> " -<"
221+ HsHigherOrderApp -> " -<<"
222+ placeHanging (exprPlacement (unLoc input)) $
223+ located input p_hsExpr
224+ HsCmdArrForm NoExt form Prefix _ cmds -> banana $ sitcc $ do
225+ located form p_hsExpr
226+ unless (null cmds) $ do
227+ breakpoint
228+ inci (sequence_ (intersperse breakpoint (located' p_hsCmdTop <$> cmds)))
229+ HsCmdArrForm NoExt form Infix _ [left, right] -> do
230+ located left p_hsCmdTop
231+ space
232+ located form p_hsExpr
233+ placeHanging (cmdTopPlacement (unLoc right)) $
234+ located right p_hsCmdTop
235+ HsCmdArrForm NoExt _ Infix _ _ -> notImplemented "HsCmdArrForm"
236+ HsCmdApp {} ->
237+ -- XXX Does this ever occur in the syntax tree? It does not seem like it
238+ -- does. Open an issue and ping @yumiova if this ever occurs in output.
239+ notImplemented "HsCmdApp"
240+ HsCmdLam NoExt mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup
241+ HsCmdPar NoExt c -> parens (located c p_hsCmd)
242+ HsCmdCase NoExt e mgroup -> do
243+ txt "case "
244+ located e p_hsExpr
245+ txt " of"
246+ breakpoint
247+ inci (p_matchGroup' cmdPlacement p_hsCmd Case mgroup)
248+ HsCmdIf NoExt _ if' then' else' -> do
249+ txt "if "
250+ located if' p_hsExpr
251+ breakpoint
252+ txt "then"
253+ located then' $ \x -> do
254+ breakpoint
255+ inci (p_hsCmd x)
256+ breakpoint
257+ txt "else"
258+ located else' $ \x -> do
259+ breakpoint
260+ inci (p_hsCmd x)
261+ HsCmdLet NoExt localBinds c -> do
262+ txt "let "
263+ sitcc (located localBinds p_hsLocalBinds)
264+ breakpoint
265+ txt "in "
266+ sitcc (located c p_hsCmd)
267+ HsCmdDo NoExt es -> do
268+ txt "do"
269+ newline
270+ inci (located es (newlineSep (located' (sitcc . p_stmt' p_hsCmd))))
271+ HsCmdWrap {} -> notImplemented "HsCmdWrap"
272+ XCmd {} -> notImplemented "XCmd"
273+
274+p_hsCmdTop :: HsCmdTop GhcPs -> R ()
275+p_hsCmdTop = \case
276+ HsCmdTop NoExt cmd -> located cmd p_hsCmd
277+ XCmdTop {} -> notImplemented "XHsCmdTop"
186
278
187p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
279p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
188−p_stmt = \case
280+p_stmt = p_stmt' p_hsExpr
281+
282+p_stmt'
283+ :: Data body
284+ => (body -> R ())
285+ -> Stmt GhcPs (Located body)
286+ -> R ()
287+p_stmt' pretty = \case
189− LastStmt NoExt body _ _ -> located body p_hsExpr
288+ LastStmt NoExt body _ _ -> located body pretty
190 BindStmt NoExt l f _ _ -> do
289 BindStmt NoExt l f _ _ -> do
191 located l p_pat
290 located l p_pat
192 space
291 space
193 txt "<-"
292 txt "<-"
194 breakpoint
293 breakpoint
195− inci (located f p_hsExpr)
294+ inci (located f pretty)
196 ApplicativeStmt {} -> notImplemented "ApplicativeStmt"
295 ApplicativeStmt {} -> notImplemented "ApplicativeStmt"
197− BodyStmt NoExt body _ _ -> located body p_hsExpr
296+ BodyStmt NoExt body _ _ -> located body pretty
198 LetStmt NoExt binds -> do
297 LetStmt NoExt binds -> do
199 txt "let "
298 txt "let "
200 sitcc $ located binds p_hsLocalBinds
299 sitcc $ located binds p_hsLocalBinds
@@ -202,7 +301,9 @@ p_stmt = \case
202 sequence_ $ intersperse breakpoint $
301 sequence_ $ intersperse breakpoint $
203 withSep (txt "| ") p_parStmtBlock stmts
302 withSep (txt "| ") p_parStmtBlock stmts
204 TransStmt {} -> notImplemented "TransStmt"
303 TransStmt {} -> notImplemented "TransStmt"
205− RecStmt {} -> notImplemented "RecStmt"
304+ RecStmt {..} -> do
305+ txt "rec "
306+ sitcc $ newlineSep (located' (p_stmt' pretty)) recS_stmts
206 XStmtLR {} -> notImplemented "XStmtLR"
307 XStmtLR {} -> notImplemented "XStmtLR"
207
308
208p_parStmtBlock :: ParStmtBlock GhcPs GhcPs -> R ()
309p_parStmtBlock :: ParStmtBlock GhcPs GhcPs -> R ()
@@ -434,13 +535,22 @@ p_hsExpr = \case
434 HsRnBracketOut {} -> notImplemented "HsRnBracketOut"
535 HsRnBracketOut {} -> notImplemented "HsRnBracketOut"
435 HsTcBracketOut {} -> notImplemented "HsTcBracketOut"
536 HsTcBracketOut {} -> notImplemented "HsTcBracketOut"
436 HsSpliceE NoExt splice -> p_hsSplice splice
537 HsSpliceE NoExt splice -> p_hsSplice splice
437− HsProc {} -> notImplemented "HsProc"
538+ HsProc NoExt p e -> do
539+ txt "proc"
540+ located p $ \x -> do
541+ breakpoint
542+ inci (p_pat x)
543+ breakpoint
544+ txt "->"
545+ placeHanging (cmdTopPlacement (unLoc e)) (located e p_hsCmdTop)
438 HsStatic _ e -> do
546 HsStatic _ e -> do
439 txt "static"
547 txt "static"
440 breakpoint
548 breakpoint
441 inci (located e p_hsExpr)
549 inci (located e p_hsExpr)
442− HsArrApp {} -> notImplemented "HsArrApp"
550+ HsArrApp NoExt body input arrType cond ->
443− HsArrForm {} -> notImplemented "HsArrForm"
551+ p_hsCmd (HsCmdArrApp NoExt body input arrType cond)
552+ HsArrForm NoExt form mfixity cmds ->
553+ p_hsCmd (HsCmdArrForm NoExt form Prefix mfixity cmds)
444 HsTick {} -> notImplemented "HsTick"
554 HsTick {} -> notImplemented "HsTick"
445 HsBinTick {} -> notImplemented "HsBinTick"
555 HsBinTick {} -> notImplemented "HsBinTick"
446 HsTickPragma {} -> notImplemented "HsTickPragma"
556 HsTickPragma {} -> notImplemented "HsTickPragma"
@@ -630,7 +740,7 @@ p_hsBracket = \case
630----------------------------------------------------------------------------
740----------------------------------------------------------------------------
631-- Helpers
741-- Helpers
632
742
633−getGRHSSpan :: GRHS GhcPs (LHsExpr GhcPs) -> SrcSpan
743+getGRHSSpan :: GRHS GhcPs (Located body) -> SrcSpan
634getGRHSSpan (GRHS NoExt _ body) = getLoc body
744getGRHSSpan (GRHS NoExt _ body) = getLoc body
635getGRHSSpan (XGRHS NoExt) = notImplemented "XGRHS"
745getGRHSSpan (XGRHS NoExt) = notImplemented "XGRHS"
636
746
@@ -651,9 +761,26 @@ placeHanging placement m = do
651-- | Check if given block contains single expression which has a hanging
761-- | Check if given block contains single expression which has a hanging
652-- form.
762-- form.
653
763
654−blockPlacement :: [LGRHS GhcPs (LHsExpr GhcPs)] -> Placement
764+blockPlacement
765+ :: (body -> Placement)
766+ -> [LGRHS GhcPs (Located body)]
767+ -> Placement
655−blockPlacement [(L _ (GRHS NoExt _ (L _ e)))] = exprPlacement e
768+blockPlacement placer [(L _ (GRHS NoExt _ (L _ x)))] = placer x
656−blockPlacement _ = Normal
769+blockPlacement _ _ = Normal
770+
771+-- | Check if given command has a hanging form.
772+
773+cmdPlacement :: HsCmd GhcPs -> Placement
774+cmdPlacement = \case
775+ HsCmdLam NoExt _ -> Hanging
776+ HsCmdCase NoExt _ _ -> Hanging
777+ HsCmdDo NoExt _ -> Hanging
778+ _ -> Normal
779+
780+cmdTopPlacement :: HsCmdTop GhcPs -> Placement
781+cmdTopPlacement = \case
782+ HsCmdTop NoExt (L _ x) -> cmdPlacement x
783+ XCmdTop {} -> notImplemented "XCmdTop"
657
784
658-- | Check if given expression has hinging a form.
785-- | Check if given expression has hinging a form.
659
786
@@ -665,11 +792,17 @@ exprPlacement = \case
665 HsDo NoExt DoExpr _ -> Hanging
792 HsDo NoExt DoExpr _ -> Hanging
666 HsDo NoExt MDoExpr _ -> Hanging
793 HsDo NoExt MDoExpr _ -> Hanging
667 RecordCon NoExt _ _ -> Hanging
794 RecordCon NoExt _ _ -> Hanging
795+ HsProc NoExt (L s _) _ ->
796+ -- Indentation breaks if pattern is longer than one line and left hanging.
797+ -- Consequentally, once apply hanging when it is safe.
798+ if isOneLineSpan s
799+ then Hanging
800+ else Normal
668 _ -> Normal
801 _ -> Normal
669
802
670−withGuards :: [LGRHS GhcPs (LHsExpr GhcPs)] -> Bool
803+withGuards :: [LGRHS GhcPs (Located body)] -> Bool
671withGuards = any (checkOne . unLoc)
804withGuards = any (checkOne . unLoc)
672 where
805 where
673− checkOne :: GRHS GhcPs (LHsExpr GhcPs) -> Bool
806+ checkOne :: GRHS GhcPs (Located body) -> Bool
674 checkOne (GRHS NoExt [] _) = False
807 checkOne (GRHS NoExt [] _) = False
675 checkOne _ = True
808 checkOne _ = True