@@ -1,4 +1,5 @@
11{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE MultiWayIf #-}
23{-# LANGUAGE OverloadedStrings #-}
34{-# LANGUAGE RecordWildCards #-}
45{-# LANGUAGE TypeApplications #-}
@@ -26,7 +27,7 @@ import qualified Data.List.NonEmpty as NE
2627import Data.Text (Text)
2728import qualified Data.Text as Text
2829import GHC
29−import OccName (mkVarOcc)
30+import OccName (occNameString)
3031import Ormolu.Printer.Combinators
3132import Ormolu.Printer.Internal
3233import Ormolu.Printer.Meat.Common
@@ -60,7 +61,7 @@ data Placement
6061 -- should use it and avoid bumping one level
6162 -- of indentation
6263 Hanging
63− deriving (Eq)
64+ deriving (Eq, Show)
6465
6566p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
6667p_valDecl = \case
@@ -180,13 +181,15 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
180181 SrcStrict -> txt "!"
181182 SrcLazy -> txt "~"
182183 indentBody <- case NE.nonEmpty m_pats of
183− Nothing -> False <$ case style of
184− Function name -> p_rdrName name
185− _ -> return ()
184+ Nothing ->
185+ False <$ case style of
186+ Function name -> p_rdrName name
187+ _ -> return ()
186188 Just ne_pats -> do
187− let combinedSpans =
188− combineSrcSpans' $
189− getLoc <$> ne_pats
189+ let combinedSpans = case style of
190+ Function name -> combineSrcSpans (getLoc name) patSpans
191+ _ -> patSpans
192+ patSpans = combineSrcSpans' (getLoc <$> ne_pats)
190193 indentBody = not (isOneLineSpan combinedSpans)
191194 switchLayout [combinedSpans] $ do
192195 let stdCase = sep breakpoint (located' p_pat) m_pats
@@ -350,7 +353,14 @@ p_hsCmdTop = \case
350353 HsCmdTop NoExtField cmd -> located cmd p_hsCmd
351354 XCmdTop x -> noExtCon x
352355
353−withSpacing :: Data a => (a -> R ()) -> Located a -> R ()
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 ()
354364withSpacing f l = located l $ \x -> do
355365 case getLoc l of
356366 UnhelpfulSpan _ -> f x
@@ -461,30 +471,24 @@ gatherStmtBlock (XParStmtBlock x) = noExtCon x
461471p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()
462472p_hsLocalBinds = \case
463473 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
472474 -- When in a single-line layout, there is a chance that the inner
473475 -- elements will also contain semicolons and they will confuse the
474476 -- parser. so we request braces around every element except the last.
475477 br <- layoutToBraces <$> getLayout
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)
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)
488492 HsValBinds NoExtField _ -> notImplemented "HsValBinds"
489493 HsIPBinds NoExtField (IPBinds NoExtField xs) ->
490494 -- Second argument of IPBind is always Left before type-checking.
@@ -517,12 +521,6 @@ p_hsRecField HsRecField {..} = do
517521 else Normal
518522 placeHanging placement (located hsRecFieldArg p_hsExpr)
519523
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−
526524p_hsExpr :: HsExpr GhcPs -> R ()
527525p_hsExpr = p_hsExpr' N
528526
@@ -592,9 +590,10 @@ p_hsExpr' s = \case
592590 L _ (HsAppType NoExtField _ _) -> True
593591 L _ (HsMultiIf NoExtField _) -> True
594592 L spn _ -> isOneLineSpan spn
595− ub <- getLayout <&> \case
596− SingleLine -> useBraces
597− MultiLine -> id
593+ ub <-
594+ getLayout <&> \case
595+ SingleLine -> useBraces
596+ MultiLine -> id
598597 ub $ do
599598 located func (p_hsExpr' s)
600599 breakpoint
@@ -614,10 +613,15 @@ p_hsExpr' s = \case
614613 breakpoint
615614 inci $ do
616615 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 ()
617621 located (hswc_body a) p_hsType
618622 OpApp NoExtField x op y -> do
619623 let opTree = OpBranch (exprOpTree x) op (exprOpTree y)
620− p_exprOpTree True s (reassociateOpTree getOpName opTree)
624+ p_exprOpTree s (reassociateOpTree getOpName opTree)
621625 NegApp NoExtField e _ -> do
622626 txt "-"
623627 space
@@ -634,22 +638,27 @@ p_hsExpr' s = \case
634638 let isRecordDot' = isRecordDot (unLoc op) (getLoc x)
635639 unless (useRecordDot' && isRecordDot') breakpoint
636640 inci (located x p_hsExpr)
637− ExplicitTuple NoExtField args boxity -> do
641+ ExplicitTuple NoExtField args boxity ->
638642 let isSection = any (isMissing . unLoc) args
639643 isMissing = \case
640644 Missing NoExtField -> True
641645 _ -> False
642− let parens' =
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' =
643652 case boxity of
644653 Boxed -> parens
645654 Unboxed -> parensHash
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
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
653662 ExplicitSum NoExtField tag arity e ->
654663 p_unboxedSum N tag arity (located e p_hsExpr)
655664 HsCase NoExtField e mgroup ->
@@ -671,7 +680,7 @@ p_hsExpr' s = \case
671680 sepSemi
672681 (ub . withSpacing (p_stmt' exprPlacement (p_hsExpr' S)))
673682 (unLoc es)
674− compBody = brackets N $ located es $ \xs -> do
683+ compBody = brackets N . located es $ \xs -> do
675684 let p_parBody =
676685 sep
677686 (breakpoint >> txt "|" >> space)
@@ -1222,11 +1231,10 @@ exprPlacement = \case
12221231 HsCase NoExtField _ _ -> Hanging
12231232 HsDo NoExtField DoExpr _ -> Hanging
12241233 HsDo NoExtField MDoExpr _ -> Hanging
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)
1234+ OpApp NoExtField _ op y ->
1235+ case (fmap getOpNameStr . getOpName . unLoc) op of
1236+ Just "$" -> exprPlacement (unLoc y)
1237+ _ -> Normal
12301238 HsApp NoExtField _ y -> exprPlacement (unLoc y)
12311239 HsProc NoExtField p _ ->
12321240 -- Indentation breaks if pattern is longer than one line and left
@@ -1252,15 +1260,16 @@ getOpName = \case
12521260 HsVar NoExtField (L _ a) -> Just a
12531261 _ -> Nothing
12541262
1263+getOpNameStr :: RdrName -> String
1264+getOpNameStr = occNameString . rdrNameOcc
1265+
12551266p_exprOpTree ::
1256− -- | Can use special handling of dollar?
1257− Bool ->
12581267 -- | Bracket style to use
12591268 BracketStyle ->
12601269 OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) ->
12611270 R ()
1262−p_exprOpTree _ s (OpNode x) = located x (p_hsExpr' s)
1263−p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
1271+p_exprOpTree s (OpNode x) = located x (p_hsExpr' s)
1272+p_exprOpTree s (OpBranch x op y) = do
12641273 -- If the beginning of the first argument and the second argument are on
12651274 -- the same line, and the second argument has a hanging form, use hanging
12661275 -- placement.
@@ -1282,44 +1291,54 @@ p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
12821291 MultiLine -> case placement of
12831292 Hanging -> useBraces
12841293 Normal -> dontUseBraces
1285− gotDollar = case getOpName (unLoc op) of
1286− Just rname -> mkVarOcc "$" == rdrNameOcc rname
1287− _ -> False
1294+ opNameStr = (fmap getOpNameStr . getOpName . unLoc) op
1295+ gotDollar = opNameStr == Just "$"
1296+ gotColon = opNameStr == Just ":"
1297+ gotRecordDot = isRecordDot (unLoc op) (opTreeLoc y)
12881298 lhs =
12891299 switchLayout [opTreeLoc x] $
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)
1300+ p_exprOpTree s x
1301+ p_op = located op (opWrapper . p_hsExpr)
1302+ p_y = switchLayout [opTreeLoc y] (p_exprOpTree N y)
12931303 isSection = case (opTreeLoc x, getLoc op) of
12941304 (RealSrcSpan treeSpan, RealSrcSpan opSpan) ->
12951305 srcSpanEndCol treeSpan /= srcSpanStartCol opSpan
12961306 _ -> False
1307+ isDoBlock = \case
1308+ OpNode (L _ HsDo {}) -> True
1309+ _ -> False
12971310 useRecordDot' <- useRecordDot
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
1311+ if
1312+ | gotColon -> do
1313+ lhs
1314+ space
1315+ p_op
1316+ case placement of
1317+ Hanging -> do
13211318 space
13221319 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
13231342
13241343-- | Return 'True' if given expression is a record-dot operator expression.
13251344isRecordDot ::
@@ -1330,14 +1349,10 @@ isRecordDot ::
13301349 Bool
13311350isRecordDot op (RealSrcSpan ySpan) = case op of
13321351 HsVar NoExtField (L (RealSrcSpan opSpan) opName) ->
1333− isDot opName && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)
1352+ (getOpNameStr opName == ".") && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)
13341353 _ -> False
13351354isRecordDot _ _ = False
13361355
1337−-- | Check whether a given 'RdrName' is the dot operator.
1338−isDot :: RdrName -> Bool
1339−isDot name = rdrNameOcc name == mkVarOcc "."
1340−
13411356-- | Get annotations for the enclosing element.
13421357getEnclosingAnns :: R [AnnKeywordId]
13431358getEnclosingAnns = do