@@ -1,5 +1,4 @@
11{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE MultiWayIf #-}
32{-# LANGUAGE OverloadedStrings #-}
43{-# LANGUAGE RecordWildCards #-}
54{-# LANGUAGE TypeApplications #-}
@@ -27,7 +26,7 @@ import qualified Data.List.NonEmpty as NE
2726import Data.Text (Text)
2827import qualified Data.Text as Text
2928import GHC
30−import OccName (occNameString)
29+import OccName (mkVarOcc)
3130import Ormolu.Printer.Combinators
3231import Ormolu.Printer.Internal
3332import Ormolu.Printer.Meat.Common
@@ -61,7 +60,7 @@ data Placement
6160 -- should use it and avoid bumping one level
6261 -- of indentation
6362 Hanging
64− deriving (Eq, Show)
63+ deriving (Eq)
6564
6665p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
6766p_valDecl = \case
@@ -181,15 +180,13 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
181180 SrcStrict -> txt "!"
182181 SrcLazy -> txt "~"
183182 indentBody <- case NE.nonEmpty m_pats of
184− Nothing ->
185− False <$ case style of
186− Function name -> p_rdrName name
187− _ -> return ()
183+ Nothing -> False <$ case style of
184+ Function name -> p_rdrName name
185+ _ -> return ()
188186 Just ne_pats -> do
189− let combinedSpans = case style of
190− Function name -> combineSrcSpans (getLoc name) patSpans
191− _ -> patSpans
192− patSpans = combineSrcSpans' (getLoc <$> ne_pats)
187+ let combinedSpans =
188+ combineSrcSpans' $
189+ getLoc <$> ne_pats
193190 indentBody = not (isOneLineSpan combinedSpans)
194191 switchLayout [combinedSpans] $ do
195192 let stdCase = sep breakpoint (located' p_pat) m_pats
@@ -353,14 +350,7 @@ p_hsCmdTop = \case
353350 HsCmdTop NoExtField cmd -> located cmd p_hsCmd
354351 XCmdTop x -> noExtCon x
355352
356−-- | Render an expression preserving blank lines between such consecutive
357−-- expressions found in the original source code.
358−withSpacing ::
359− -- | Rendering function
360− (a -> R ()) ->
361− -- | Entity to render
362− Located a ->
363− R ()
353+withSpacing :: Data a => (a -> R ()) -> Located a -> R ()
364354withSpacing f l = located l $ \x -> do
365355 case getLoc l of
366356 UnhelpfulSpan _ -> f x
@@ -471,24 +461,30 @@ gatherStmtBlock (XParStmtBlock x) = noExtCon x
471461p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()
472462p_hsLocalBinds = \case
473463 HsValBinds NoExtField (ValBinds NoExtField bag lsigs) -> do
464+ let ssStart =
465+ either
466+ (srcSpanStart . getLoc)
467+ (srcSpanStart . getLoc)
468+ items =
469+ (Left <$> bagToList bag) ++ (Right <$> lsigs)
470+ p_item (Left x) = located x p_valDecl
471+ p_item (Right x) = located x p_sigDecl
474472 -- When in a single-line layout, there is a chance that the inner
475473 -- elements will also contain semicolons and they will confuse the
476474 -- parser. so we request braces around every element except the last.
477475 br <- layoutToBraces <$> getLayout
478− let items =
479− let injectLeft (L l x) = L l (Left x)
480− injectRight (L l x) = L l (Right x)
481− in (injectLeft <$> bagToList bag) ++ (injectRight <$> lsigs)
482− positionToBracing = \case
483− SinglePos -> id
484− FirstPos -> br
485− MiddlePos -> br
486− LastPos -> id
487− p_item' (p, item) =
488− positionToBracing p $
489− withSpacing (either p_valDecl p_sigDecl) item
490− binds = sortOn (srcSpanStart . getLoc) items
491− sitcc $ sepSemi p_item' (attachRelativePos binds)
476+ sitcc $
477+ sepSemi
478+ ( \(p, i) ->
479+ ( case p of
480+ SinglePos -> id
481+ FirstPos -> br
482+ MiddlePos -> br
483+ LastPos -> id
484+ )
485+ (p_item i)
486+ )
487+ (attachRelativePos $ sortOn ssStart items)
492488 HsValBinds NoExtField _ -> notImplemented "HsValBinds"
493489 HsIPBinds NoExtField (IPBinds NoExtField xs) ->
494490 -- Second argument of IPBind is always Left before type-checking.
@@ -521,6 +517,12 @@ p_hsRecField HsRecField {..} = do
521517 else Normal
522518 placeHanging placement (located hsRecFieldArg p_hsExpr)
523519
520+p_hsTupArg :: HsTupArg GhcPs -> R ()
521+p_hsTupArg = \case
522+ Present NoExtField x -> located x p_hsExpr
523+ Missing NoExtField -> pure ()
524+ XTupArg x -> noExtCon x
525+
524526p_hsExpr :: HsExpr GhcPs -> R ()
525527p_hsExpr = p_hsExpr' N
526528
@@ -590,10 +592,9 @@ p_hsExpr' s = \case
590592 L _ (HsAppType NoExtField _ _) -> True
591593 L _ (HsMultiIf NoExtField _) -> True
592594 L spn _ -> isOneLineSpan spn
593− ub <-
594− getLayout <&> \case
595− SingleLine -> useBraces
596− MultiLine -> id
595+ ub <- getLayout <&> \case
596+ SingleLine -> useBraces
597+ MultiLine -> id
597598 ub $ do
598599 located func (p_hsExpr' s)
599600 breakpoint
@@ -613,15 +614,10 @@ p_hsExpr' s = \case
613614 breakpoint
614615 inci $ do
615616 txt "@"
616− -- Insert a space when the type is represented as a TH splice to avoid
617− -- gluing @ and $ together.
618− case unLoc (hswc_body a) of
619− HsSpliceTy {} -> space
620− _ -> return ()
621617 located (hswc_body a) p_hsType
622618 OpApp NoExtField x op y -> do
623619 let opTree = OpBranch (exprOpTree x) op (exprOpTree y)
624− p_exprOpTree s (reassociateOpTree getOpName opTree)
620+ p_exprOpTree True s (reassociateOpTree getOpName opTree)
625621 NegApp NoExtField e _ -> do
626622 txt "-"
627623 space
@@ -638,27 +634,22 @@ p_hsExpr' s = \case
638634 let isRecordDot' = isRecordDot (unLoc op) (getLoc x)
639635 unless (useRecordDot' && isRecordDot') breakpoint
640636 inci (located x p_hsExpr)
641− ExplicitTuple NoExtField args boxity ->
637+ ExplicitTuple NoExtField args boxity -> do
642638 let isSection = any (isMissing . unLoc) args
643639 isMissing = \case
644640 Missing NoExtField -> True
645641 _ -> False
646− p_arg = \case
647− Present NoExtField x -> located x p_hsExpr
648− Missing NoExtField -> pure ()
649− XTupArg x -> noExtCon x
650− p_larg = sitcc . located' p_arg
651− parens' =
642+ let parens' =
652643 case boxity of
653644 Boxed -> parens
654645 Unboxed -> parensHash
655− in if isSection
656− then
657− switchLayout [] . parens' s $
658− sep comma p_larg args
659− else
660− switchLayout (getLoc <$> args) . parens' s $
661− sep commaDel p_larg args
646+ if isSection
647+ then
648+ switchLayout [] . parens' s $
649+ sep comma (located' p_hsTupArg) args
650+ else
651+ switchLayout (getLoc <$> args) . parens' s $
652+ sep commaDel (sitcc . located' p_hsTupArg) args
662653 ExplicitSum NoExtField tag arity e ->
663654 p_unboxedSum N tag arity (located e p_hsExpr)
664655 HsCase NoExtField e mgroup ->
@@ -680,7 +671,7 @@ p_hsExpr' s = \case
680671 sepSemi
681672 (ub . withSpacing (p_stmt' exprPlacement (p_hsExpr' S)))
682673 (unLoc es)
683− compBody = brackets N . located es $ \xs -> do
674+ compBody = brackets N $ located es $ \xs -> do
684675 let p_parBody =
685676 sep
686677 (breakpoint >> txt "|" >> space)
@@ -1231,10 +1222,11 @@ exprPlacement = \case
12311222 HsCase NoExtField _ _ -> Hanging
12321223 HsDo NoExtField DoExpr _ -> Hanging
12331224 HsDo NoExtField MDoExpr _ -> Hanging
1234− OpApp NoExtField _ op y ->
1235− case (fmap getOpNameStr . getOpName . unLoc) op of
1236− Just "$" -> exprPlacement (unLoc y)
1237− _ -> Normal
1225+ -- If the rightmost expression in an operator chain is hanging, make the
1226+ -- whole block hanging; so that we can use the common @f = foo $ do@
1227+ -- style.
1228+ OpApp NoExtField _ _ y -> exprPlacement (unLoc y)
1229+ -- Same thing for function applications (usually with -XBlockArguments)
12381230 HsApp NoExtField _ y -> exprPlacement (unLoc y)
12391231 HsProc NoExtField p _ ->
12401232 -- Indentation breaks if pattern is longer than one line and left
@@ -1260,16 +1252,15 @@ getOpName = \case
12601252 HsVar NoExtField (L _ a) -> Just a
12611253 _ -> Nothing
12621254
1263−getOpNameStr :: RdrName -> String
1264−getOpNameStr = occNameString . rdrNameOcc
1265−
12661255p_exprOpTree ::
1256+ -- | Can use special handling of dollar?
1257+ Bool ->
12671258 -- | Bracket style to use
12681259 BracketStyle ->
12691260 OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) ->
12701261 R ()
1271−p_exprOpTree s (OpNode x) = located x (p_hsExpr' s)
1272−p_exprOpTree s (OpBranch x op y) = do
1262+p_exprOpTree _ s (OpNode x) = located x (p_hsExpr' s)
1263+p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
12731264 -- If the beginning of the first argument and the second argument are on
12741265 -- the same line, and the second argument has a hanging form, use hanging
12751266 -- placement.
@@ -1291,54 +1282,44 @@ p_exprOpTree s (OpBranch x op y) = do
12911282 MultiLine -> case placement of
12921283 Hanging -> useBraces
12931284 Normal -> dontUseBraces
1294− opNameStr = (fmap getOpNameStr . getOpName . unLoc) op
1295− gotDollar = opNameStr == Just "$"
1296− gotColon = opNameStr == Just ":"
1297− gotRecordDot = isRecordDot (unLoc op) (opTreeLoc y)
1285+ gotDollar = case getOpName (unLoc op) of
1286+ Just rname -> mkVarOcc "$" == rdrNameOcc rname
1287+ _ -> False
12981288 lhs =
12991289 switchLayout [opTreeLoc x] $
1300− p_exprOpTree s x
1301− p_op = located op (opWrapper . p_hsExpr)
1302− p_y = switchLayout [opTreeLoc y] (p_exprOpTree N y)
1290+ p_exprOpTree (not gotDollar) s x
1291+ let p_op = located op (opWrapper . p_hsExpr)
1292+ p_y = switchLayout [opTreeLoc y] (p_exprOpTree True N y)
13031293 isSection = case (opTreeLoc x, getLoc op) of
13041294 (RealSrcSpan treeSpan, RealSrcSpan opSpan) ->
13051295 srcSpanEndCol treeSpan /= srcSpanStartCol opSpan
13061296 _ -> False
1307− isDoBlock = \case
1308− OpNode (L _ HsDo {}) -> True
1309− _ -> False
13101297 useRecordDot' <- useRecordDot
1311− if
1312− | gotColon -> do
1313− lhs
1314− space
1315− p_op
1316− case placement of
1317− Hanging -> do
1298+ let isRecordDot' = isRecordDot (unLoc op) (opTreeLoc y)
1299+ if useRecordDot' && isRecordDot'
1300+ then do
1301+ lhs
1302+ when isSection space
1303+ p_op
1304+ p_y
1305+ else
1306+ if isDollarSpecial
1307+ && gotDollar
1308+ && placement
1309+ == Normal
1310+ && isOneLineSpan (opTreeLoc x)
1311+ then do
1312+ useBraces lhs
1313+ space
1314+ p_op
1315+ breakpoint
1316+ inci p_y
1317+ else do
1318+ ub lhs
1319+ placeHanging placement $ do
1320+ p_op
13181321 space
13191322 p_y
1320− Normal -> do
1321− breakpoint
1322− inciIf (isDoBlock y) p_y
1323− | gotDollar
1324− && isOneLineSpan (opTreeLoc x)
1325− && placement == Normal -> do
1326− useBraces lhs
1327− space
1328− p_op
1329− breakpoint
1330− inci p_y
1331− | useRecordDot' && gotRecordDot -> do
1332− lhs
1333− when isSection space
1334− p_op
1335− p_y
1336− | otherwise -> do
1337− ub lhs
1338− placeHanging placement $ do
1339− p_op
1340− space
1341− p_y
13421323
13431324-- | Return 'True' if given expression is a record-dot operator expression.
13441325isRecordDot ::
@@ -1349,10 +1330,14 @@ isRecordDot ::
13491330 Bool
13501331isRecordDot op (RealSrcSpan ySpan) = case op of
13511332 HsVar NoExtField (L (RealSrcSpan opSpan) opName) ->
1352− (getOpNameStr opName == ".") && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)
1333+ isDot opName && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)
13531334 _ -> False
13541335isRecordDot _ _ = False
13551336
1337+-- | Check whether a given 'RdrName' is the dot operator.
1338+isDot :: RdrName -> Bool
1339+isDot name = rdrNameOcc name == mkVarOcc "."
1340+
13561341-- | Get annotations for the enclosing element.
13571342getEnclosingAnns :: R [AnnKeywordId]
13581343getEnclosingAnns = do