@@ -1,4 +1,5 @@
11{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE MultiWayIf #-}
23{-# LANGUAGE OverloadedStrings #-}
34{-# LANGUAGE RecordWildCards #-}
45{-# LANGUAGE TypeApplications #-}
@@ -21,12 +22,12 @@ import Data.Char (isPunctuation, isSymbol)
2122import Data.Data hiding (Infix, Prefix)
2223import Data.Functor ((<&>))
2324import Data.List (intersperse, sortOn)
24−import Data.List.NonEmpty ((<|), NonEmpty (..))
25+import Data.List.NonEmpty (NonEmpty (..), (<|))
2526import 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
@@ -179,25 +180,24 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
179180 NoSrcStrict -> return ()
180181 SrcStrict -> txt "!"
181182 SrcLazy -> txt "~"
182− inci' <- case NE.nonEmpty m_pats of
183− Nothing -> id <$ case style of
184− Function name -> p_rdrName name
185− _ -> return ()
183+ indentBody <- case NE.nonEmpty m_pats of
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
190− inci' =
191− if isOneLineSpan combinedSpans
192− then id
193− else inci
189+ let combinedSpans = case style of
190+ Function name -> combineSrcSpans (getLoc name) patSpans
191+ _ -> patSpans
192+ patSpans = combineSrcSpans' (getLoc <$> ne_pats)
193+ indentBody = not (isOneLineSpan combinedSpans)
194194 switchLayout [combinedSpans] $ do
195195 let stdCase = sep breakpoint (located' p_pat) m_pats
196196 case style of
197197 Function name ->
198198 p_infixDefHelper
199199 isInfix
200− inci'
200+ indentBody
201201 (p_rdrName name)
202202 (located' p_pat <$> m_pats)
203203 PatternBind -> stdCase
@@ -212,7 +212,7 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
212212 when needsSpace space
213213 sitcc stdCase
214214 LambdaCase -> stdCase
215− return inci'
215+ return indentBody
216216 let -- Calculate position of end of patterns. This is useful when we decide
217217 -- about putting certain constructions in hanging positions.
218218 endOfPats = case NE.nonEmpty m_pats of
@@ -224,7 +224,7 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
224224 Case -> True
225225 LambdaCase -> True
226226 _ -> False
227− let hasGuards = withGuards grhssGRHSs
227+ hasGuards = withGuards grhssGRHSs
228228 grhssSpan =
229229 combineSrcSpans' $
230230 getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs
@@ -253,7 +253,7 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
253253 txt "where"
254254 unless whereIsEmpty breakpoint
255255 inci $ located grhssLocalBinds p_hsLocalBinds
256− inci' $ do
256+ inciIf indentBody $ do
257257 unless (length grhssGRHSs > 1) $
258258 case style of
259259 Function _ | hasGuards -> return ()
@@ -284,7 +284,7 @@ p_grhs' placer render style (GRHS NoExtField guards body) =
284284 xs -> do
285285 txt "|"
286286 space
287− sitcc (sep (comma >> breakpoint) (sitcc . located' p_stmt) xs)
287+ sitcc (sep commaDel (sitcc . located' p_stmt) xs)
288288 space
289289 inci $ case style of
290290 EqualSign -> equals
@@ -316,7 +316,7 @@ p_hsCmd = \case
316316 HsHigherOrderApp -> txt "-<<"
317317 placeHanging (exprPlacement (unLoc input)) $
318318 located input p_hsExpr
319− HsCmdArrForm NoExtField form Prefix _ cmds -> banana $ sitcc $ do
319+ HsCmdArrForm NoExtField form Prefix _ cmds -> banana $ do
320320 located form p_hsExpr
321321 unless (null cmds) $ do
322322 breakpoint
@@ -353,7 +353,14 @@ p_hsCmdTop = \case
353353 HsCmdTop NoExtField cmd -> located cmd p_hsCmd
354354 XCmdTop x -> noExtCon x
355355
356−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 ()
357364withSpacing f l = located l $ \x -> do
358365 case getLoc l of
359366 UnhelpfulSpan _ -> f x
@@ -464,30 +471,24 @@ gatherStmtBlock (XParStmtBlock x) = noExtCon x
464471p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()
465472p_hsLocalBinds = \case
466473 HsValBinds NoExtField (ValBinds NoExtField bag lsigs) -> do
467− let ssStart =
468− either
469− (srcSpanStart . getLoc)
470− (srcSpanStart . getLoc)
471− items =
472− (Left <$> bagToList bag) ++ (Right <$> lsigs)
473− p_item (Left x) = located x p_valDecl
474− p_item (Right x) = located x p_sigDecl
475474 -- When in a single-line layout, there is a chance that the inner
476475 -- elements will also contain semicolons and they will confuse the
477476 -- parser. so we request braces around every element except the last.
478477 br <- layoutToBraces <$> getLayout
479− sitcc $
480− sepSemi
481− ( \(p, i) ->
482− ( case p of
483− SinglePos -> id
484− FirstPos -> br
485− MiddlePos -> br
486− LastPos -> id
487− )
488− (p_item i)
489− )
490− (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)
491492 HsValBinds NoExtField _ -> notImplemented "HsValBinds"
492493 HsIPBinds NoExtField (IPBinds NoExtField xs) ->
493494 -- Second argument of IPBind is always Left before type-checking.
@@ -520,12 +521,6 @@ p_hsRecField HsRecField {..} = do
520521 else Normal
521522 placeHanging placement (located hsRecFieldArg p_hsExpr)
522523
523−p_hsTupArg :: HsTupArg GhcPs -> R ()
524−p_hsTupArg = \case
525− Present NoExtField x -> located x p_hsExpr
526− Missing NoExtField -> pure ()
527− XTupArg x -> noExtCon x
528−
529524p_hsExpr :: HsExpr GhcPs -> R ()
530525p_hsExpr = p_hsExpr' N
531526
@@ -589,23 +584,21 @@ p_hsExpr' s = \case
589584 -- do-block or case expression it is not a good idea. It seems
590585 -- to be safe to always bump indentation when the function
591586 -- expression is parenthesised.
592− indent =
587+ doIndent =
593588 case func of
594− L _ (HsPar NoExtField _) -> inci
595− L _ (HsAppType NoExtField _ _) -> inci
596− L _ (HsMultiIf NoExtField _) -> inci
597− L spn _ ->
598− if isOneLineSpan spn
599− then inci
600− else id
601− ub <- getLayout <&> \case
602− SingleLine -> useBraces
603− MultiLine -> id
589+ L _ (HsPar NoExtField _) -> True
590+ L _ (HsAppType NoExtField _ _) -> True
591+ L _ (HsMultiIf NoExtField _) -> True
592+ L spn _ -> isOneLineSpan spn
593+ ub <-
594+ getLayout <&> \case
595+ SingleLine -> useBraces
596+ MultiLine -> id
604597 ub $ do
605598 located func (p_hsExpr' s)
606599 breakpoint
607− indent $ sep breakpoint (located' p_hsExpr) initp
608− indent $ do
600+ inciIf doIndent $ sep breakpoint (located' p_hsExpr) initp
601+ inciIf doIndent $ do
609602 unless (null initp) breakpoint
610603 located lastp p_hsExpr
611604 Hanging -> do
@@ -620,10 +613,15 @@ p_hsExpr' s = \case
620613 breakpoint
621614 inci $ do
622615 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 ()
623621 located (hswc_body a) p_hsType
624622 OpApp NoExtField x op y -> do
625623 let opTree = OpBranch (exprOpTree x) op (exprOpTree y)
626− p_exprOpTree True s (reassociateOpTree getOpName opTree)
624+ p_exprOpTree s (reassociateOpTree getOpName opTree)
627625 NegApp NoExtField e _ -> do
628626 txt "-"
629627 space
@@ -640,22 +638,27 @@ p_hsExpr' s = \case
640638 let isRecordDot' = isRecordDot (unLoc op) (getLoc x)
641639 unless (useRecordDot' && isRecordDot') breakpoint
642640 inci (located x p_hsExpr)
643− ExplicitTuple NoExtField args boxity -> do
641+ ExplicitTuple NoExtField args boxity ->
644642 let isSection = any (isMissing . unLoc) args
645643 isMissing = \case
646644 Missing NoExtField -> True
647645 _ -> False
648− 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' =
649652 case boxity of
650653 Boxed -> parens
651654 Unboxed -> parensHash
652− if isSection
653− then
654− switchLayout [] . parens' s $
655− sep comma (located' p_hsTupArg) args
656− else
657− switchLayout (getLoc <$> args) . parens' s . sitcc $
658− sep (comma >> breakpoint) (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
659662 ExplicitSum NoExtField tag arity e ->
660663 p_unboxedSum N tag arity (located e p_hsExpr)
661664 HsCase NoExtField e mgroup ->
@@ -665,7 +668,7 @@ p_hsExpr' s = \case
665668 HsMultiIf NoExtField guards -> do
666669 txt "if"
667670 breakpoint
668− inci . inci . sitcc $ sep newline (located' (p_grhs RightArrow)) guards
671+ inci . inci $ sep newline (located' (p_grhs RightArrow)) guards
669672 HsLet NoExtField localBinds e ->
670673 p_let p_hsExpr localBinds e
671674 HsDo NoExtField ctx es -> do
@@ -677,15 +680,15 @@ p_hsExpr' s = \case
677680 sepSemi
678681 (ub . withSpacing (p_stmt' exprPlacement (p_hsExpr' S)))
679682 (unLoc es)
680− compBody = brackets N $ located es $ \xs -> do
683+ compBody = brackets N . located es $ \xs -> do
681684 let p_parBody =
682685 sep
683− (breakpoint >> txt "| ")
686+ (breakpoint >> txt "|" >> space)
684687 p_seqBody
685688 p_seqBody =
686689 sitcc
687690 . sep
688− (comma >> breakpoint)
691+ commaDel
689692 (located' (sitcc . p_stmt))
690693 stmts = init xs
691694 yield = last xs
@@ -706,8 +709,8 @@ p_hsExpr' s = \case
706709 ParStmtCtxt _ -> notImplemented "ParStmtCtxt"
707710 TransStmtCtxt _ -> notImplemented "TransStmtCtxt"
708711 ExplicitList _ _ xs ->
709− brackets s . sitcc $
710− sep (comma >> breakpoint) (sitcc . located' p_hsExpr) xs
712+ brackets s $
713+ sep commaDel (sitcc . located' p_hsExpr) xs
711714 RecordCon {..} -> do
712715 located rcon_con_name atom
713716 breakpoint
@@ -723,8 +726,8 @@ p_hsExpr' s = \case
723726 case rec_dotdot of
724727 Just {} -> [txt ".."]
725728 Nothing -> []
726− inci . braces N . sitcc $
727− sep (comma >> breakpoint) sitcc (fields <> dotdot)
729+ inci . braces N $
730+ sep commaDel sitcc (fields <> dotdot)
728731 RecordUpd {..} -> do
729732 located rupd_expr p_hsExpr
730733 useRecordDot' <- useRecordDot
@@ -742,9 +745,9 @@ p_hsExpr' s = \case
742745 Unambiguous _ n -> n
743746 XAmbiguousFieldOcc x -> noExtCon x
744747 }
745− inci . braces N . sitcc $
748+ inci . braces N $
746749 sep
747− (comma >> breakpoint)
750+ commaDel
748751 (sitcc . located' (p_hsRecField . updName))
749752 rupd_flds
750753 ExprWithTySig NoExtField x HsWC {hswc_body = HsIB {..}} -> sitcc $ do
@@ -757,22 +760,22 @@ p_hsExpr' s = \case
757760 ExprWithTySig NoExtField _ (XHsWildCardBndrs x) -> noExtCon x
758761 ArithSeq NoExtField _ x ->
759762 case x of
760− From from -> brackets s . sitcc $ do
763+ From from -> brackets s $ do
761764 located from p_hsExpr
762765 breakpoint
763766 txt ".."
764− FromThen from next -> brackets s . sitcc $ do
765− sitcc $ sep (comma >> breakpoint) (located' p_hsExpr) [from, next]
767+ FromThen from next -> brackets s $ do
768+ sep commaDel (located' p_hsExpr) [from, next]
766769 breakpoint
767770 txt ".."
768− FromTo from to -> brackets s . sitcc $ do
771+ FromTo from to -> brackets s $ do
769772 located from p_hsExpr
770773 breakpoint
771774 txt ".."
772775 space
773776 located to p_hsExpr
774− FromThenTo from next to -> brackets s . sitcc $ do
775− sitcc $ sep (comma >> breakpoint) (located' p_hsExpr) [from, next]
777+ FromThenTo from next to -> brackets s $ do
778+ sep commaDel (located' p_hsExpr) [from, next]
776779 breakpoint
777780 txt ".."
778781 space
@@ -849,8 +852,8 @@ p_patSynBind PSB {..} = do
849852 inci $ do
850853 switchLayout (getLoc . recordPatSynPatVar <$> xs) $ do
851854 unless (null xs) breakpoint
852− braces N . sitcc $
853− sep (comma >> breakpoint) (p_rdrName . recordPatSynPatVar) xs
855+ braces N $
856+ sep commaDel (p_rdrName . recordPatSynPatVar) xs
854857 rhs
855858 InfixCon l r -> do
856859 switchLayout [getLoc l, getLoc r] $ do
@@ -904,10 +907,12 @@ p_if placer render if' then' else' = do
904907 breakpoint
905908 inci $ do
906909 txt "then"
910+ space
907911 located then' $ \x ->
908912 placeHanging (placer x) (render x)
909913 breakpoint
910914 txt "else"
915+ space
911916 located else' $ \x ->
912917 placeHanging (placer x) (render x)
913918
@@ -944,13 +949,13 @@ p_pat = \case
944949 txt "!"
945950 located pat p_pat
946951 ListPat NoExtField pats ->
947− brackets S . sitcc $ sep (comma >> breakpoint) (located' p_pat) pats
952+ brackets S $ sep commaDel (located' p_pat) pats
948953 TuplePat NoExtField pats boxing -> do
949− let f =
954+ let parens' =
950955 case boxing of
951956 Boxed -> parens S
952957 Unboxed -> parensHash S
953− f . sitcc $ sep (comma >> breakpoint) (sitcc . located' p_pat) pats
958+ parens' $ sep commaDel (sitcc . located' p_pat) pats
954959 SumPat NoExtField pat tag arity ->
955960 p_unboxedSum S tag arity (located pat p_pat)
956961 ConPatIn pat details ->
@@ -966,7 +971,7 @@ p_pat = \case
966971 let f = \case
967972 Nothing -> txt ".."
968973 Just x -> located x p_pat_hsRecField
969− inci . braces N . sitcc . sep (comma >> breakpoint) f $
974+ inci . braces N . sep commaDel f $
970975 case dotdot of
971976 Nothing -> Just <$> fields
972977 Just (L _ n) -> (Just <$> take n fields) ++ [Nothing]
@@ -1016,17 +1021,15 @@ p_unboxedSum s tag arity m = do
10161021 let before = tag - 1
10171022 after = arity - before - 1
10181023 args = replicate before Nothing <> [Just m] <> replicate after Nothing
1019− f (x, i) = do
1020− let isFirst = i == 0
1021− isLast = i == arity - 1
1024+ f x =
10221025 case x :: Maybe (R ()) of
10231026 Nothing ->
1024− unless (isFirst || isLast) space
1027+ space
10251028 Just m' -> do
1026− unless isFirst space
1029+ space
10271030 m'
1028− unless isLast space
1029− parensHash s $ sep (txt "|") f (zip args [0 ..])
1031+ space
1032+ parensHash s $ sep (txt "|") f args
10301033
10311034p_hsSplice :: HsSplice GhcPs -> R ()
10321035p_hsSplice = \case
@@ -1228,11 +1231,10 @@ exprPlacement = \case
12281231 HsCase NoExtField _ _ -> Hanging
12291232 HsDo NoExtField DoExpr _ -> Hanging
12301233 HsDo NoExtField MDoExpr _ -> Hanging
1231− -- If the rightmost expression in an operator chain is hanging, make the
1232− -- whole block hanging; so that we can use the common @f = foo $ do@
1233− -- style.
1234− OpApp NoExtField _ _ y -> exprPlacement (unLoc y)
1235− -- 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
12361238 HsApp NoExtField _ y -> exprPlacement (unLoc y)
12371239 HsProc NoExtField p _ ->
12381240 -- Indentation breaks if pattern is longer than one line and left
@@ -1258,15 +1260,16 @@ getOpName = \case
12581260 HsVar NoExtField (L _ a) -> Just a
12591261 _ -> Nothing
12601262
1263+getOpNameStr :: RdrName -> String
1264+getOpNameStr = occNameString . rdrNameOcc
1265+
12611266p_exprOpTree ::
1262− -- | Can use special handling of dollar?
1263− Bool ->
12641267 -- | Bracket style to use
12651268 BracketStyle ->
12661269 OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) ->
12671270 R ()
1268−p_exprOpTree _ s (OpNode x) = located x (p_hsExpr' s)
1269−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
12701273 -- If the beginning of the first argument and the second argument are on
12711274 -- the same line, and the second argument has a hanging form, use hanging
12721275 -- placement.
@@ -1288,44 +1291,54 @@ p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
12881291 MultiLine -> case placement of
12891292 Hanging -> useBraces
12901293 Normal -> dontUseBraces
1291− gotDollar = case getOpName (unLoc op) of
1292− Just rname -> mkVarOcc "$" == rdrNameOcc rname
1293− _ -> False
1294+ opNameStr = (fmap getOpNameStr . getOpName . unLoc) op
1295+ gotDollar = opNameStr == Just "$"
1296+ gotColon = opNameStr == Just ":"
1297+ gotRecordDot = isRecordDot (unLoc op) (opTreeLoc y)
12941298 lhs =
12951299 switchLayout [opTreeLoc x] $
1296− p_exprOpTree (not gotDollar) s x
1297− let p_op = located op (opWrapper . p_hsExpr)
1298− 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)
12991303 isSection = case (opTreeLoc x, getLoc op) of
13001304 (RealSrcSpan treeSpan, RealSrcSpan opSpan) ->
13011305 srcSpanEndCol treeSpan /= srcSpanStartCol opSpan
13021306 _ -> False
1307+ isDoBlock = \case
1308+ OpNode (L _ HsDo {}) -> True
1309+ _ -> False
13031310 useRecordDot' <- useRecordDot
1304− let isRecordDot' = isRecordDot (unLoc op) (opTreeLoc y)
1305− if useRecordDot' && isRecordDot'
1306− then do
1307− lhs
1308− when isSection space
1309− p_op
1310− p_y
1311− else
1312− if isDollarSpecial
1313− && gotDollar
1314− && placement
1315− == Normal
1316− && isOneLineSpan (opTreeLoc x)
1317− then do
1318− useBraces lhs
1319− space
1320− p_op
1321− breakpoint
1322− inci p_y
1323− else do
1324− ub lhs
1325− placeHanging placement $ do
1326− p_op
1311+ if
1312+ | gotColon -> do
1313+ lhs
1314+ space
1315+ p_op
1316+ case placement of
1317+ Hanging -> do
13271318 space
13281319 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
13291342
13301343-- | Return 'True' if given expression is a record-dot operator expression.
13311344isRecordDot ::
@@ -1336,14 +1349,10 @@ isRecordDot ::
13361349 Bool
13371350isRecordDot op (RealSrcSpan ySpan) = case op of
13381351 HsVar NoExtField (L (RealSrcSpan opSpan) opName) ->
1339− isDot opName && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)
1352+ (getOpNameStr opName == ".") && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)
13401353 _ -> False
13411354isRecordDot _ _ = False
13421355
1343−-- | Check whether a given 'RdrName' is the dot operator.
1344−isDot :: RdrName -> Bool
1345−isDot name = rdrNameOcc name == mkVarOcc "."
1346−
13471356-- | Get annotations for the enclosing element.
13481357getEnclosingAnns :: R [AnnKeywordId]
13491358getEnclosingAnns = do