@@ -13,7 +13,7 @@ where
1313import Bag (bagToList)
1414import BasicTypes
1515import Control.Monad
16−import Data.Data
16+import Data.Data hiding (Infix, Prefix)
1717import Data.List (intersperse, sortOn)
1818import Data.Text (Text)
1919import GHC
@@ -72,11 +72,20 @@ p_matchGroup
7272 :: MatchGroupStyle
7373 -> MatchGroup GhcPs (LHsExpr GhcPs)
7474 -> 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 {..} =
7685 locatedVia Nothing mg_alts $
7786 newlineSep (located' (\m@Match {..} ->
78− p_match style (isInfixMatch m) m_pats m_grhss))
79−p_matchGroup _ (XMatchGroup NoExt) = notImplemented "XMatchGroup"
87+ p_match' placer pretty style (isInfixMatch m) m_pats m_grhss))
88+p_matchGroup' _ _ _ (XMatchGroup NoExt) = notImplemented "XMatchGroup"
8089
8190p_match
8291 :: MatchGroupStyle
@@ -84,7 +93,18 @@ p_match
8493 -> [LPat GhcPs]
8594 -> GRHSs GhcPs (LHsExpr GhcPs)
8695 -> R ()
87−p_match style isInfix m_pats m_grhss = do
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 ()
107+p_match' placer pretty style isInfix m_pats m_grhss = do
88108 -- NOTE Normally, since patterns may be placed in a multi-line layout, it
89109 -- is necessary to bump indentation for the pattern group so it's more
90110 -- indented than function name. This in turn means that indentation for
@@ -144,7 +164,7 @@ p_match style isInfix m_pats m_grhss = do
144164 let grhssSpan = combineSrcSpans' $
145165 getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs
146166 patGrhssSpan = maybe grhssSpan (combineSrcSpans grhssSpan) endOfPatsSpan
147− placement = blockPlacement grhssGRHSs
167+ placement = blockPlacement placer grhssGRHSs
148168 inciLocalBinds = case placement of
149169 Normal -> id
150170 Hanging -> inci
@@ -153,7 +173,7 @@ p_match style isInfix m_pats m_grhss = do
153173 if isCase style && hasGuards
154174 then RightArrow
155175 else EqualSign
156− newlineSep (located' (p_grhs groupStyle)) grhssGRHSs
176+ newlineSep (located' (p_grhs' pretty groupStyle)) grhssGRHSs
157177 unless
158178 (GHC.isEmptyLocalBindsPR (unLoc grhssLocalBinds))
159179 (inciLocalBinds $ do
@@ -168,7 +188,15 @@ p_match style isInfix m_pats m_grhss = do
168188 placeHanging placement p_body
169189
170190p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R ()
171−p_grhs style (GRHS NoExt guards body) =
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 ()
199+p_grhs' pretty style (GRHS NoExt guards body) =
172200 case guards of
173201 [] -> p_body
174202 xs -> do
@@ -181,20 +209,91 @@ p_grhs style (GRHS NoExt guards body) =
181209 breakpoint
182210 inci p_body
183211 where
184− p_body = located body p_hsExpr
185−p_grhs _ (XGRHS NoExt) = notImplemented "XGRHS"
212+ p_body = located body pretty
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"
186278
187279p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
188−p_stmt = \case
189− LastStmt NoExt body _ _ -> located body p_hsExpr
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
288+ LastStmt NoExt body _ _ -> located body pretty
190289 BindStmt NoExt l f _ _ -> do
191290 located l p_pat
192291 space
193292 txt "<-"
194293 breakpoint
195− inci (located f p_hsExpr)
294+ inci (located f pretty)
196295 ApplicativeStmt {} -> notImplemented "ApplicativeStmt"
197− BodyStmt NoExt body _ _ -> located body p_hsExpr
296+ BodyStmt NoExt body _ _ -> located body pretty
198297 LetStmt NoExt binds -> do
199298 txt "let "
200299 sitcc $ located binds p_hsLocalBinds
@@ -202,7 +301,9 @@ p_stmt = \case
202301 sequence_ $ intersperse breakpoint $
203302 withSep (txt "| ") p_parStmtBlock stmts
204303 TransStmt {} -> notImplemented "TransStmt"
205− RecStmt {} -> notImplemented "RecStmt"
304+ RecStmt {..} -> do
305+ txt "rec "
306+ sitcc $ newlineSep (located' (p_stmt' pretty)) recS_stmts
206307 XStmtLR {} -> notImplemented "XStmtLR"
207308
208309p_parStmtBlock :: ParStmtBlock GhcPs GhcPs -> R ()
@@ -434,13 +535,22 @@ p_hsExpr = \case
434535 HsRnBracketOut {} -> notImplemented "HsRnBracketOut"
435536 HsTcBracketOut {} -> notImplemented "HsTcBracketOut"
436537 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)
438546 HsStatic _ e -> do
439547 txt "static"
440548 breakpoint
441549 inci (located e p_hsExpr)
442− HsArrApp {} -> notImplemented "HsArrApp"
443− HsArrForm {} -> notImplemented "HsArrForm"
550+ HsArrApp NoExt body input arrType cond ->
551+ p_hsCmd (HsCmdArrApp NoExt body input arrType cond)
552+ HsArrForm NoExt form mfixity cmds ->
553+ p_hsCmd (HsCmdArrForm NoExt form Prefix mfixity cmds)
444554 HsTick {} -> notImplemented "HsTick"
445555 HsBinTick {} -> notImplemented "HsBinTick"
446556 HsTickPragma {} -> notImplemented "HsTickPragma"
@@ -630,7 +740,7 @@ p_hsBracket = \case
630740----------------------------------------------------------------------------
631741-- Helpers
632742
633−getGRHSSpan :: GRHS GhcPs (LHsExpr GhcPs) -> SrcSpan
743+getGRHSSpan :: GRHS GhcPs (Located body) -> SrcSpan
634744getGRHSSpan (GRHS NoExt _ body) = getLoc body
635745getGRHSSpan (XGRHS NoExt) = notImplemented "XGRHS"
636746
@@ -651,9 +761,26 @@ placeHanging placement m = do
651761-- | Check if given block contains single expression which has a hanging
652762-- form.
653763
654−blockPlacement :: [LGRHS GhcPs (LHsExpr GhcPs)] -> Placement
655−blockPlacement [(L _ (GRHS NoExt _ (L _ e)))] = exprPlacement e
656−blockPlacement _ = Normal
764+blockPlacement
765+ :: (body -> Placement)
766+ -> [LGRHS GhcPs (Located body)]
767+ -> Placement
768+blockPlacement placer [(L _ (GRHS NoExt _ (L _ x)))] = placer x
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"
657784
658785-- | Check if given expression has hinging a form.
659786
@@ -665,11 +792,17 @@ exprPlacement = \case
665792 HsDo NoExt DoExpr _ -> Hanging
666793 HsDo NoExt MDoExpr _ -> Hanging
667794 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
668801 _ -> Normal
669802
670−withGuards :: [LGRHS GhcPs (LHsExpr GhcPs)] -> Bool
803+withGuards :: [LGRHS GhcPs (Located body)] -> Bool
671804withGuards = any (checkOne . unLoc)
672805 where
673− checkOne :: GRHS GhcPs (LHsExpr GhcPs) -> Bool
806+ checkOne :: GRHS GhcPs (Located body) -> Bool
674807 checkOne (GRHS NoExt [] _) = False
675808 checkOne _ = True