1273 lines
49 KiB
Haskell
1273 lines
49 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE MonadComprehensions #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
|
|
module Language.Haskell.Brittany.Internal.ToBriDoc.Expr where
|
|
|
|
import qualified Data.Sequence as Seq
|
|
import qualified Data.Text as Text
|
|
import GHC (GenLocated(L), RdrName(..))
|
|
import qualified GHC.Data.FastString as FastString
|
|
import GHC.Types.SourceText
|
|
(IntegralLit(IL), FractionalLit(FL), SourceText(SourceText))
|
|
import GHC.Hs
|
|
import qualified GHC.Types.SrcLoc as GHC
|
|
import qualified GHC.OldList as List
|
|
import GHC.Types.Basic
|
|
import GHC.Types.Name
|
|
import Language.Haskell.Brittany.Internal.Config.Types
|
|
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
|
|
import Language.Haskell.Brittany.Internal.ToBriDoc.Decl
|
|
import Language.Haskell.Brittany.Internal.ToBriDoc.Pattern
|
|
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.ToBriDoc.Stmt
|
|
import Language.Haskell.Brittany.Internal.ToBriDoc.Type
|
|
import Language.Haskell.Brittany.Internal.Prelude
|
|
import Language.Haskell.Brittany.Internal.Types
|
|
import Language.Haskell.Brittany.Internal.Utils
|
|
import Language.Haskell.Brittany.Internal.Components.BriDoc
|
|
|
|
|
|
|
|
layoutExpr :: ToBriDoc HsExpr
|
|
layoutExpr lexpr@(L _ expr) = do
|
|
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
|
|
let allowFreeIndent = indentPolicy == IndentPolicyFree
|
|
docHandleComms lexpr $ case expr of
|
|
HsVar NoExtField vname -> docHandleComms lexpr $ do
|
|
docLit =<< lrdrNameToTextAnn vname
|
|
HsUnboundVar epAnn oname -> docHandleComms epAnn $ do
|
|
docLit $ Text.pack $ occNameString oname
|
|
HsRecFld{} -> docHandleComms lexpr $ do
|
|
-- TODO
|
|
briDocByExactInlineOnly "HsRecFld" lexpr
|
|
HsOverLabel _ext name -> -- TODO92
|
|
let label = FastString.unpackFS name in docLit . Text.pack $ '#' : label
|
|
HsIPVar _ext (HsIPName name) -> -- TODO92
|
|
let label = FastString.unpackFS name in docLit . Text.pack $ '?' : label
|
|
HsOverLit epAnn olit -> docHandleComms epAnn $ do
|
|
allocateNode $ overLitValBriDoc $ ol_val olit
|
|
HsLit epAnn lit -> docHandleComms epAnn $ do
|
|
allocateNode $ litBriDoc lit
|
|
HsLam _ (MG _ (L _ [(L _ match)]) _)
|
|
| pats <- m_pats match
|
|
, GRHSs _ [lgrhs] llocals <- m_grhss match
|
|
, EmptyLocalBinds{} <- llocals
|
|
, L _ (GRHS epAnn [] body) <- lgrhs
|
|
-> do
|
|
patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) ->
|
|
fmap return $ do
|
|
-- this code could be as simple as `colsWrapPat =<< layoutPat p`
|
|
-- if it was not for the following two cases:
|
|
-- \ !x -> x
|
|
-- \ ~x -> x
|
|
-- These make it necessary to special-case an additional separator.
|
|
-- (TODO: we create a BDCols here, but then make it ineffective
|
|
-- by wrapping it in docSeq below. We _could_ add alignments for
|
|
-- stuff like lists-of-lambdas. Nothing terribly important..)
|
|
let
|
|
shouldPrefixSeparator = case p of
|
|
L _ LazyPat{} -> isFirst
|
|
L _ BangPat{} -> isFirst
|
|
_ -> False
|
|
patDocSeq <- layoutPat p
|
|
fixed <- case Seq.viewl patDocSeq of
|
|
p1 Seq.:< pr | shouldPrefixSeparator -> do
|
|
p1' <- docSeq [docSeparator, pure p1]
|
|
pure (p1' Seq.<| pr)
|
|
_ -> pure patDocSeq
|
|
colsWrapPat fixed
|
|
bodyDoc <- shareDoc
|
|
$ docAddBaseY BrIndentRegular
|
|
$ docHandleComms epAnn $ layoutExpr body
|
|
let
|
|
funcPatternPartLine = docCols
|
|
ColCasePattern
|
|
(patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator]))
|
|
docAlt
|
|
[ -- single line
|
|
docSeq
|
|
[ docLit $ Text.pack "\\"
|
|
, docForceSingleline funcPatternPartLine
|
|
, appSep $ docLit $ Text.pack "->"
|
|
, docForceSingleline bodyDoc
|
|
]
|
|
-- double line
|
|
, docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
|
|
(docSeq
|
|
[ docLit $ Text.pack "\\"
|
|
, appSep $ docForceSingleline
|
|
funcPatternPartLine
|
|
, docLit $ Text.pack "->"
|
|
]
|
|
)
|
|
(docForceSingleline bodyDoc)
|
|
-- wrapped par spacing
|
|
, docSetParSpacing $ docSeq
|
|
[ docLit $ Text.pack "\\"
|
|
, docForceSingleline funcPatternPartLine
|
|
, appSep $ docLit $ Text.pack "->"
|
|
, docForceParSpacing bodyDoc
|
|
]
|
|
-- conservative
|
|
, docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
|
|
(docSeq
|
|
[ docLit $ Text.pack "\\"
|
|
, appSep $ docForceSingleline
|
|
funcPatternPartLine
|
|
, docLit $ Text.pack "->"
|
|
]
|
|
)
|
|
(docNonBottomSpacing bodyDoc)
|
|
]
|
|
HsLam{} -> unknownNodeError "HsLam too complex" lexpr
|
|
HsLamCase _ (MG _ (L _ []) _) -> do
|
|
docSetParSpacing
|
|
$ docAddBaseY BrIndentRegular
|
|
$ (docLit $ Text.pack "\\case {}")
|
|
HsLamCase _ (MG _ _lmatches@(L _ matches) _) -> do
|
|
binderDoc <- docLit $ Text.pack "->"
|
|
funcPatDocs <-
|
|
-- docWrapNode lmatches
|
|
layoutPatternBind Nothing binderDoc
|
|
`mapM` matches
|
|
docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
|
|
(docLit $ Text.pack "\\case")
|
|
(docSetBaseAndIndent
|
|
$ docNonBottomSpacing
|
|
$ docLines
|
|
$ return
|
|
<$> funcPatDocs
|
|
)
|
|
HsApp _ exp1 _ -> do
|
|
let gather
|
|
:: [(EpAnnCO, LHsExpr GhcPs)]
|
|
-> LHsExpr GhcPs
|
|
-> (LHsExpr GhcPs, [(EpAnnCO, LHsExpr GhcPs)])
|
|
gather list = \case
|
|
L _ (HsApp epAnn l r) -> gather ((epAnn, r) : list) l
|
|
x -> (x, list)
|
|
let (headE, paramEs) = gather [] lexpr
|
|
let colsOrSequence = case headE of
|
|
L _ (HsVar _ (L _ (Unqual occname))) ->
|
|
docCols (ColApp $ Text.pack $ occNameString occname)
|
|
_ -> docSeq
|
|
headDoc <- shareDoc $ layoutExpr headE
|
|
paramDocs <- forM paramEs $ \(epAnn, e) ->
|
|
shareDoc $ docHandleComms epAnn $ layoutExpr e
|
|
let hasComments = hasAnyCommentsConnected exp1
|
|
runFilteredAlternative $ do
|
|
-- foo x y
|
|
addAlternativeCond (not hasComments)
|
|
$ colsOrSequence
|
|
$ appSep (docForceSingleline headDoc)
|
|
: spacifyDocs (docForceSingleline <$> paramDocs)
|
|
-- foo x do
|
|
-- a
|
|
-- b
|
|
-- foo x \meow -> do
|
|
-- a
|
|
-- b
|
|
addAlternativeCond (not hasComments) $ docSetParSpacing $ docSeq
|
|
[ appSep (docForceSingleline headDoc)
|
|
, case splitFirstLast paramDocs of
|
|
FirstLastEmpty -> docEmpty
|
|
FirstLastSingleton e1 -> docForceParSpacing e1
|
|
FirstLast e1 ems eN ->
|
|
docSeq
|
|
( spacifyDocs (docForceSingleline <$> (e1:ems))
|
|
++ [docSeparator, docForceParSpacing eN]
|
|
)
|
|
]
|
|
-- foo x
|
|
-- y
|
|
addAlternativeCond allowFreeIndent $ docSeq
|
|
[ appSep (docForceSingleline headDoc)
|
|
, docSetBaseY
|
|
$ docAddBaseY BrIndentRegular
|
|
$ docLines
|
|
$ docForceSingleline
|
|
<$> paramDocs
|
|
]
|
|
-- foo
|
|
-- x
|
|
-- y
|
|
addAlternative $ do
|
|
let checkAllowPar = \case
|
|
(_, L _ ExplicitTuple{}) -> True
|
|
(_, L _ ExplicitList{}) -> True
|
|
(_, L _ HsPar{}) -> True
|
|
_ -> False
|
|
let wrap = if all checkAllowPar paramEs then docSetParSpacing else id
|
|
wrap $ docAddBaseY BrIndentRegular $ docPar
|
|
(docForceSingleline headDoc)
|
|
(docNonBottomSpacing $ docLines paramDocs)
|
|
-- ( multi
|
|
-- line
|
|
-- function
|
|
-- )
|
|
-- x
|
|
-- y
|
|
addAlternative $ docAddBaseY BrIndentRegular $ docPar
|
|
headDoc
|
|
(docNonBottomSpacing $ docLines paramDocs)
|
|
HsAppType _ exp1 (HsWC _ ty1) -> do
|
|
t <- shareDoc $ layoutType ty1
|
|
e <- shareDoc $ layoutExpr exp1
|
|
docAlt
|
|
[ docSeq
|
|
[ docForceSingleline e
|
|
, docSeparator
|
|
, docLit $ Text.pack "@"
|
|
, docForceSingleline t
|
|
]
|
|
, docPar e (docSeq [docLit $ Text.pack "@", t])
|
|
]
|
|
OpApp _topEpAnn expLeft@(L _ OpApp{}) expOp expRight -> do
|
|
let
|
|
allowPar = case (expOp, expRight) of
|
|
(L _ (HsVar _ (L _ (Unqual occname))), _)
|
|
| occNameString occname == "$" -> True
|
|
(_, L _ (HsApp _ _ (L _ HsVar{}))) -> False
|
|
_ -> True
|
|
let
|
|
gather
|
|
:: Bool
|
|
-> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered, Bool)]
|
|
-> LHsExpr GhcPs
|
|
-> ( ToBriDocM BriDocNumbered
|
|
, [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered, Bool)]
|
|
)
|
|
gather last opExprList = \case
|
|
(L _ (OpApp epAnn l1 op1 r1)) ->
|
|
gather
|
|
False
|
|
( ( docHandleComms epAnn $ layoutExpr op1
|
|
, layoutExpr r1
|
|
, last
|
|
)
|
|
: opExprList
|
|
)
|
|
l1
|
|
final -> (layoutExpr final, opExprList)
|
|
(leftOperand, appList) = gather True [] lexpr
|
|
leftOperandDoc <- shareDoc leftOperand
|
|
appListDocs <- appList `forM` \(x, y, last) ->
|
|
[ (xD, yD, last)
|
|
| xD <- shareDoc x
|
|
, yD <- shareDoc y
|
|
]
|
|
let allowSinglelinePar = not (hasAnyCommentsConnected expLeft)
|
|
&& not (hasAnyCommentsConnected expOp)
|
|
runFilteredAlternative $ do
|
|
-- > one + two + three
|
|
-- or
|
|
-- > one + two + case x of
|
|
-- > _ -> three
|
|
addAlternativeCond allowSinglelinePar $ docSeq
|
|
[ appSep $ docForceSingleline leftOperandDoc
|
|
, docSeq $ appListDocs <&> \(od, ed, last) -> docSeq
|
|
[ appSep $ docForceSingleline od
|
|
, if last
|
|
then if allowPar
|
|
then docForceParSpacing ed
|
|
else docForceSingleline ed
|
|
else appSep $ docForceSingleline ed
|
|
]
|
|
]
|
|
-- this case rather leads to some unfortunate layouting than to anything
|
|
-- useful; disabling for now. (it interfers with cols stuff.)
|
|
-- addAlternative
|
|
-- $ docSetBaseY
|
|
-- $ docPar
|
|
-- leftOperandDoc
|
|
-- ( docLines
|
|
-- $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed])
|
|
-- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]
|
|
-- )
|
|
-- > one
|
|
-- > + two
|
|
-- > + three
|
|
addAlternative $ docPar
|
|
leftOperandDoc
|
|
(docLines $ appListDocs <&> \(od, ed, _) ->
|
|
docCols ColOpPrefix [appSep od, docSetBaseY ed]
|
|
)
|
|
OpApp epAnn expLeft expOp expRight -> docHandleComms epAnn $ do
|
|
expDocLeft <- shareDoc $ layoutExpr expLeft
|
|
expDocOp <- shareDoc $ layoutExpr expOp
|
|
expDocRight <- shareDoc $ layoutExpr expRight
|
|
let
|
|
allowPar = case (expOp, expRight) of
|
|
(L _ (HsVar _ (L _ (Unqual occname))), _)
|
|
| occNameString occname == "$" -> True
|
|
(_, L _ (HsApp _ _ (L _ HsVar{}))) -> False
|
|
_ -> True
|
|
let
|
|
leftIsDoBlock = case expLeft of
|
|
L _ HsDo{} -> True
|
|
_ -> False
|
|
runFilteredAlternative $ do
|
|
-- one-line
|
|
addAlternative $ docSeq
|
|
[ appSep $ docForceSingleline expDocLeft
|
|
, appSep $ docForceSingleline expDocOp
|
|
, docForceSingleline expDocRight
|
|
]
|
|
-- -- line + freely indented block for right expression
|
|
-- addAlternative
|
|
-- $ docSeq
|
|
-- [ appSep $ docForceSingleline expDocLeft
|
|
-- , appSep $ docForceSingleline expDocOp
|
|
-- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight
|
|
-- ]
|
|
-- two-line
|
|
addAlternative $ do
|
|
let
|
|
expDocOpAndRight = docForceSingleline $ docCols
|
|
ColOpPrefix
|
|
[appSep $ expDocOp, docSetBaseY expDocRight]
|
|
if leftIsDoBlock
|
|
then docLines [expDocLeft, expDocOpAndRight]
|
|
else docAddBaseY BrIndentRegular
|
|
$ docPar expDocLeft expDocOpAndRight
|
|
-- TODO: in both cases, we don't force expDocLeft to be
|
|
-- single-line, which has certain.. interesting consequences.
|
|
-- At least, the "two-line" label is not entirely
|
|
-- accurate.
|
|
-- one-line + par
|
|
addAlternativeCond allowPar $ docSeq
|
|
[ appSep $ docForceSingleline expDocLeft
|
|
, appSep $ docForceSingleline expDocOp
|
|
, docForceParSpacing expDocRight
|
|
]
|
|
-- more lines
|
|
addAlternative $ do
|
|
let
|
|
expDocOpAndRight =
|
|
docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight]
|
|
if leftIsDoBlock
|
|
then docLines [expDocLeft, expDocOpAndRight]
|
|
else docAddBaseY BrIndentRegular
|
|
$ docPar expDocLeft expDocOpAndRight
|
|
NegApp _ op _ -> do
|
|
opDoc <- shareDoc $ layoutExpr op
|
|
docSeq [docLit $ Text.pack "-", opDoc]
|
|
HsPar epAnn innerExp -> docHandleComms epAnn $ do
|
|
let AnnParen _ spanOpen spanClose = anns epAnn
|
|
let wrapOpen = docHandleComms spanOpen
|
|
let wrapClose = docHandleComms spanClose
|
|
innerExpDoc <- shareDoc $ layoutExpr innerExp
|
|
docAlt
|
|
[ docSeq
|
|
[ wrapOpen $ docLit $ Text.pack "("
|
|
, docForceSingleline innerExpDoc
|
|
, wrapClose $ docLit $ Text.pack ")"
|
|
]
|
|
, docSetBaseY $ docLines
|
|
[ docCols
|
|
ColOpPrefix
|
|
[ wrapOpen $ docLit $ Text.pack "("
|
|
, docAddBaseY (BrIndentSpecial 2) innerExpDoc
|
|
]
|
|
, wrapClose $ docLit $ Text.pack ")"
|
|
]
|
|
]
|
|
SectionL _ left op -> do -- TODO: add to testsuite
|
|
leftDoc <- shareDoc $ layoutExpr left
|
|
opDoc <- shareDoc $ layoutExpr op
|
|
docSeq [leftDoc, docSeparator, opDoc]
|
|
SectionR _ op right -> do -- TODO: add to testsuite
|
|
opDoc <- shareDoc $ layoutExpr op
|
|
rightDoc <- shareDoc $ layoutExpr right
|
|
docSeq [opDoc, docSeparator, rightDoc]
|
|
ExplicitTuple epAnn args boxity -> docHandleComms epAnn $ do
|
|
let (wrapOpen, wrapClose) = case anns epAnn of
|
|
[open, close] -> case boxity of
|
|
Boxed ->
|
|
( docHandleComms $ obtainAnnPos open AnnOpenP
|
|
, docHandleComms $ obtainAnnPos close AnnCloseP
|
|
)
|
|
Unboxed ->
|
|
( docHandleComms $ obtainAnnPos open AnnOpenPH
|
|
, docHandleComms $ obtainAnnPos close AnnClosePH
|
|
)
|
|
_ -> (id, id)
|
|
argDocs <- forM args $ \case
|
|
Present _ e -> shareDoc $ docHandleListElemComms layoutExpr e
|
|
Missing missingEpAnn -> shareDoc $ docHandleComms missingEpAnn docEmpty
|
|
-- let ((c1, argsWithC, c2), cRemain) = case epAnn of
|
|
-- EpAnn _ [open, close] comms ->
|
|
-- enterCommentsSplitC comms $ do
|
|
-- comms1 <- getCommentsBeforeKW open AnnOpenP
|
|
-- elems' <- args `forM` \arg -> case arg of
|
|
-- Present _ e@(L (SrcSpanAnn elEpAnn loc) _) -> do
|
|
-- commsB <- case loc of
|
|
-- GHC.RealSrcSpan span _ -> getCommentsBeforeSpan span
|
|
-- _ -> pure []
|
|
-- case elEpAnn of
|
|
-- EpAnn _ (AnnListItem items) _ -> do
|
|
-- commsA <- items `forM` \case
|
|
-- AddCommaAnn span ->
|
|
-- getCommentsBeforeEpaLocation span
|
|
-- ann1 ->
|
|
-- error $ "unexpected TrailingAnn: "
|
|
-- ++ showSDocUnsafe (ppr ann1)
|
|
-- pure $ docWrapNode (commsB, join commsA) $ layoutExpr e
|
|
-- EpAnnNotUsed -> do
|
|
-- pure $ prependComments commsB $ layoutExpr e
|
|
-- Missing (EpAnn _ epa _) -> do
|
|
-- commsB <- getCommentsBeforeEpaLocation epa
|
|
-- pure $ prependComments commsB docEmpty
|
|
-- Missing EpAnnNotUsed -> pure $ docEmpty
|
|
-- comm2 <- getCommentsBeforeKW close AnnCloseP
|
|
-- pure (comms1, elems', comm2)
|
|
-- EpAnn _ _ _ -> error "unexpected ExplicitTuple ann!"
|
|
-- EpAnnNotUsed ->
|
|
-- let argsDocs = [ case arg of
|
|
-- Present _ e -> layoutExpr e
|
|
-- Missing _ -> docEmpty
|
|
-- | arg <- args ]
|
|
-- in (([], argsDocs, []), [])
|
|
let hasComments = hasAnyCommentsBelow lexpr -- TODO92 this is slightly
|
|
-- overzealous for comments before open & after close
|
|
let
|
|
(openLit, closeLit) = case boxity of
|
|
Boxed ->
|
|
( wrapOpen $ docLit $ Text.pack "("
|
|
, wrapClose $ docLit $ Text.pack ")"
|
|
)
|
|
Unboxed ->
|
|
( wrapOpen $ docParenHashLSep
|
|
, wrapClose $ docParenHashRSep
|
|
)
|
|
case splitFirstLast argDocs of
|
|
FirstLastEmpty ->
|
|
docSeq [openLit, closeLit]
|
|
FirstLastSingleton e -> docAlt
|
|
[ docCols
|
|
ColTuple
|
|
[ openLit
|
|
, docForceSingleline e
|
|
, closeLit
|
|
]
|
|
, docSetBaseY $ docLines
|
|
[ docSeq
|
|
[ openLit
|
|
, docForceSingleline e
|
|
]
|
|
, closeLit
|
|
]
|
|
]
|
|
FirstLast e1 ems eN -> runFilteredAlternative $ do
|
|
addAlternativeCond (not hasComments)
|
|
$ docCols ColTuple
|
|
$ [docSeq [openLit, docForceSingleline e1]]
|
|
++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e])
|
|
++ [ docSeq
|
|
[ docCommaSep
|
|
, -- TODO92 docNodeAnnKW lexpr (Just AnnOpenP)
|
|
(docForceSingleline eN)
|
|
, closeLit
|
|
]
|
|
]
|
|
addAlternative
|
|
$ let
|
|
start = docCols ColTuples [appSep openLit, e1]
|
|
linesM = ems <&> \d -> docCols ColTuples [docCommaSep, d]
|
|
lineN = docCols
|
|
ColTuples
|
|
[docCommaSep, -- TODO92 docNodeAnnKW lexpr (Just AnnOpenP)
|
|
eN]
|
|
end = closeLit
|
|
in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end]
|
|
HsCase epAnn cExp (MG _ (L _ []) _) -> docHandleComms epAnn $ do
|
|
cExpDoc <- shareDoc $ layoutExpr cExp
|
|
docAlt
|
|
[ docAddBaseY BrIndentRegular $ docSeq
|
|
[ appSep $ docLit $ Text.pack "case"
|
|
, appSep $ docForceSingleline cExpDoc
|
|
, docLit $ Text.pack "of {}"
|
|
]
|
|
, docPar
|
|
(docAddBaseY BrIndentRegular
|
|
$ docPar (docLit $ Text.pack "case") cExpDoc
|
|
)
|
|
(docLit $ Text.pack "of {}")
|
|
]
|
|
HsCase epAnn cExp (MG _ lmatches@(L _ matches) _) -> docHandleComms epAnn $ do
|
|
cExpDoc <- shareDoc $ layoutExpr cExp
|
|
binderDoc <- docLit $ Text.pack "->"
|
|
funcPatDocs <-
|
|
-- docWrapNode lmatches
|
|
layoutPatternBind Nothing binderDoc
|
|
`mapM` matches
|
|
docAlt
|
|
[ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
|
|
(docSeq
|
|
[ appSep $ docLit $ Text.pack "case"
|
|
, appSep $ docForceSingleline cExpDoc
|
|
, docLit $ Text.pack "of"
|
|
]
|
|
)
|
|
(docSetBaseAndIndent
|
|
$ docNonBottomSpacing
|
|
$ docHandleComms lmatches
|
|
$ docLines
|
|
$ return
|
|
<$> funcPatDocs
|
|
)
|
|
, docPar
|
|
(docAddBaseY BrIndentRegular
|
|
$ docPar (docLit $ Text.pack "case") cExpDoc
|
|
)
|
|
(docAddBaseY BrIndentRegular $ docPar
|
|
(docLit $ Text.pack "of")
|
|
(docSetBaseAndIndent
|
|
$ docNonBottomSpacing
|
|
$ docHandleComms lmatches
|
|
$ docLines
|
|
$ return
|
|
<$> funcPatDocs
|
|
)
|
|
)
|
|
]
|
|
HsIf epAnn ifExpr thenExpr elseExpr -> docHandleComms epAnn $ do
|
|
let AnnsIf spanIf spanThen spanElse _ _ = anns epAnn
|
|
let ifDoc = docHandleComms spanIf $ docLit $ Text.pack "if"
|
|
let thenDoc = docHandleComms spanThen $ docLit $ Text.pack "then"
|
|
let elseDoc = docHandleComms spanElse $ docLit $ Text.pack "else"
|
|
ifExprDoc <- shareDoc $ layoutExpr ifExpr
|
|
thenExprDoc <- shareDoc $ layoutExpr thenExpr
|
|
elseExprDoc <- shareDoc $ layoutExpr elseExpr
|
|
let hasComments = hasAnyCommentsBelow lexpr
|
|
let
|
|
maySpecialIndent = case indentPolicy of
|
|
IndentPolicyLeft -> BrIndentRegular
|
|
IndentPolicyMultiple -> BrIndentRegular
|
|
IndentPolicyFree -> BrIndentSpecial 3
|
|
-- TODO: some of the alternatives (especially last and last-but-one)
|
|
-- overlap.
|
|
docSetIndentLevel $ runFilteredAlternative $ do
|
|
-- if _ then _ else _
|
|
addAlternativeCond (not hasComments) $ docSeq
|
|
[ appSep $ ifDoc
|
|
, appSep $ docForceSingleline ifExprDoc
|
|
, appSep $ thenDoc
|
|
, appSep $ docForceSingleline thenExprDoc
|
|
, appSep $ elseDoc
|
|
, docForceSingleline elseExprDoc
|
|
]
|
|
-- either
|
|
-- if expr
|
|
-- then foo
|
|
-- bar
|
|
-- else foo
|
|
-- bar
|
|
-- or
|
|
-- if expr
|
|
-- then
|
|
-- stuff
|
|
-- else
|
|
-- stuff
|
|
-- note that this has par-spacing
|
|
addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
|
|
(docSeq
|
|
[ -- TODO92 docNodeAnnKW lexpr Nothing $
|
|
appSep $ ifDoc
|
|
, -- TODO92 docNodeAnnKW lexpr (Just AnnIf) $
|
|
docForceSingleline ifExprDoc
|
|
]
|
|
)
|
|
(docLines
|
|
[ docAddBaseY BrIndentRegular
|
|
-- TODO92 $ docNodeAnnKW lexpr (Just AnnThen)
|
|
$ docNonBottomSpacing
|
|
$ docAlt
|
|
[ docSeq
|
|
[ appSep $ thenDoc
|
|
, docForceParSpacing thenExprDoc
|
|
]
|
|
, docAddBaseY BrIndentRegular
|
|
$ docPar (thenDoc) thenExprDoc
|
|
]
|
|
, docAddBaseY BrIndentRegular $ docNonBottomSpacing $ docAlt
|
|
[ docSeq
|
|
[ appSep $ elseDoc
|
|
, docForceParSpacing elseExprDoc
|
|
]
|
|
, docAddBaseY BrIndentRegular
|
|
$ docPar elseDoc elseExprDoc
|
|
]
|
|
]
|
|
)
|
|
-- either
|
|
-- if multi
|
|
-- line
|
|
-- condition
|
|
-- then foo
|
|
-- bar
|
|
-- else foo
|
|
-- bar
|
|
-- or
|
|
-- if multi
|
|
-- line
|
|
-- condition
|
|
-- then
|
|
-- stuff
|
|
-- else
|
|
-- stuff
|
|
-- note that this does _not_ have par-spacing
|
|
addAlternative $ docAddBaseY BrIndentRegular $ docPar
|
|
(docAddBaseY maySpecialIndent $ docSeq
|
|
[ -- TODO92 docNodeAnnKW lexpr Nothing $
|
|
appSep $ ifDoc
|
|
, -- TODO92 docNodeAnnKW lexpr (Just AnnIf) $
|
|
ifExprDoc
|
|
]
|
|
)
|
|
(docLines
|
|
[ docAddBaseY BrIndentRegular
|
|
-- TODO92 $ docNodeAnnKW lexpr (Just AnnThen)
|
|
$ docAlt
|
|
[ docSeq
|
|
[ appSep $ thenDoc
|
|
, docForceParSpacing thenExprDoc
|
|
]
|
|
, docAddBaseY BrIndentRegular
|
|
$ docPar (thenDoc) thenExprDoc
|
|
]
|
|
, docAddBaseY BrIndentRegular $ docAlt
|
|
[ docSeq
|
|
[ appSep $ elseDoc
|
|
, docForceParSpacing elseExprDoc
|
|
]
|
|
, docAddBaseY BrIndentRegular
|
|
$ docPar elseDoc elseExprDoc
|
|
]
|
|
]
|
|
)
|
|
addAlternative $ docSetBaseY $ docLines
|
|
[ docAddBaseY maySpecialIndent $ docSeq
|
|
[ -- TODO92 docNodeAnnKW lexpr Nothing $
|
|
appSep $ ifDoc
|
|
, -- TODO92 docNodeAnnKW lexpr (Just AnnIf) $
|
|
ifExprDoc
|
|
]
|
|
, -- TODO92 docNodeAnnKW lexpr (Just AnnThen) $
|
|
docAddBaseY BrIndentRegular
|
|
$ docPar (thenDoc) thenExprDoc
|
|
, docAddBaseY BrIndentRegular
|
|
$ docPar elseDoc elseExprDoc
|
|
]
|
|
HsMultiIf epAnn cases -> do
|
|
binderDoc <- docLit $ Text.pack "->"
|
|
let hasComments =
|
|
hasAnyCommentsBelow epAnn
|
|
|| any (\(L _ (GRHS gEpAnn _ _)) -> hasAnyCommentsBelow gEpAnn) cases
|
|
let posIf = obtainAnnPos epAnn AnnIf
|
|
docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
|
|
(docHandleComms posIf $ docLit $ Text.pack "if")
|
|
(layoutPatternBindFinal
|
|
Nothing
|
|
binderDoc
|
|
Nothing
|
|
(Right cases)
|
|
Nothing
|
|
hasComments
|
|
)
|
|
HsLet epAnn binds exp1 -> docHandleComms epAnn $ do
|
|
let AnnsLet spanLet spanIn = anns epAnn
|
|
let hasComments = hasAnyCommentsBelow lexpr
|
|
let wrapLet = docHandleComms spanLet
|
|
let wrapIn = docHandleComms spanIn
|
|
mBindDocs <- layoutLocalBinds binds
|
|
let
|
|
ifIndentFreeElse :: a -> a -> a
|
|
ifIndentFreeElse x y = case indentPolicy of
|
|
IndentPolicyLeft -> y
|
|
IndentPolicyMultiple -> y
|
|
IndentPolicyFree -> x
|
|
expDoc1 <- shareDoc $ layoutExpr exp1
|
|
-- this `docSetBaseAndIndent` might seem out of place (especially the
|
|
-- Indent part; setBase is necessary due to the use of docLines below),
|
|
-- but is here due to ghc-exactprint's DP handling of "let" in
|
|
-- particular.
|
|
-- Just pushing another indentation level is a straightforward approach
|
|
-- to making brittany idempotent, even though the result is non-optimal
|
|
-- if "let" is moved horizontally as part of the transformation, as the
|
|
-- comments before the first let item are moved horizontally with it.
|
|
letDoc <- shareDoc $ wrapLet $ docLit $ Text.pack "let"
|
|
inDoc <- shareDoc $ wrapIn $ docLit $ Text.pack "in"
|
|
docSetBaseAndIndent $ case fmap snd mBindDocs of
|
|
Just [bindDoc] -> runFilteredAlternative $ do
|
|
addAlternativeCond (not hasComments) $ docSeq
|
|
[ appSep $ letDoc
|
|
, appSep $ docForceSingleline (pure bindDoc)
|
|
, appSep $ inDoc
|
|
, docForceSingleline expDoc1
|
|
]
|
|
addAlternative $ docLines
|
|
[ docAlt
|
|
[ docSeq
|
|
[ appSep $ letDoc
|
|
, ifIndentFreeElse docSetBaseAndIndent docForceSingleline
|
|
$ pure bindDoc
|
|
]
|
|
, docAddBaseY BrIndentRegular $ docPar
|
|
(letDoc)
|
|
(docSetBaseAndIndent $ pure bindDoc)
|
|
]
|
|
, docAlt
|
|
[ docSeq
|
|
[ appSep $ wrapIn $ docLit $ Text.pack $ ifIndentFreeElse "in " "in"
|
|
, ifIndentFreeElse
|
|
docSetBaseAndIndent
|
|
docForceSingleline
|
|
expDoc1
|
|
]
|
|
, docAddBaseY BrIndentRegular
|
|
$ docPar (inDoc) (docSetBaseY expDoc1)
|
|
]
|
|
]
|
|
Just bindDocs@(_ : _) -> runFilteredAlternative $ do
|
|
--either
|
|
-- let
|
|
-- a = b
|
|
-- c = d
|
|
-- in foo
|
|
-- bar
|
|
-- baz
|
|
--or
|
|
-- let
|
|
-- a = b
|
|
-- c = d
|
|
-- in
|
|
-- fooooooooooooooooooo
|
|
let
|
|
noHangingBinds =
|
|
[ docNonBottomSpacing $ docAddBaseY BrIndentRegular $ docPar
|
|
(letDoc)
|
|
(docSetBaseAndIndent $ docLines $ pure <$> bindDocs)
|
|
, docSeq
|
|
[ wrapIn $ docLit $ Text.pack "in "
|
|
, docAddBaseY BrIndentRegular $ docForceParSpacing expDoc1
|
|
]
|
|
]
|
|
addAlternative $ case indentPolicy of
|
|
IndentPolicyLeft -> docLines noHangingBinds
|
|
IndentPolicyMultiple -> docLines noHangingBinds
|
|
IndentPolicyFree -> docLines
|
|
[ -- TODO92 docNodeAnnKW lexpr (Just AnnLet) $
|
|
docSeq
|
|
[ appSep $ letDoc
|
|
, docSetBaseAndIndent $ docLines $ pure <$> bindDocs
|
|
]
|
|
, docSeq [appSep $ wrapIn $ docLit $ Text.pack "in ", docSetBaseY expDoc1]
|
|
]
|
|
addAlternative $ docLines
|
|
[ -- TODO92 docNodeAnnKW lexpr (Just AnnLet) $
|
|
docAddBaseY BrIndentRegular
|
|
$ docPar
|
|
(letDoc)
|
|
(docSetBaseAndIndent $ docLines $ pure <$> bindDocs)
|
|
, docAddBaseY BrIndentRegular
|
|
$ docPar (inDoc) (docSetBaseY $ expDoc1)
|
|
]
|
|
_ -> docSeq
|
|
[ docForceSingleline $ docSeq
|
|
[ letDoc
|
|
, docSeparator
|
|
, inDoc
|
|
]
|
|
, docSeparator
|
|
, expDoc1
|
|
]
|
|
-- docSeq [appSep $ docLit "let in", expDoc1]
|
|
HsDo epAnn stmtCtx (L (SrcSpanAnn stmtEpAnn _) stmts) ->
|
|
docHandleComms epAnn $ do
|
|
case stmtCtx of
|
|
DoExpr _ -> do
|
|
stmtDocs <- docHandleComms stmtEpAnn $ do
|
|
stmts `forM` docHandleListElemComms layoutStmt
|
|
docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
|
|
(docLit $ Text.pack "do")
|
|
(docSetBaseAndIndent
|
|
$ docNonBottomSpacing
|
|
$ docLines
|
|
$ pure <$> stmtDocs
|
|
)
|
|
MDoExpr _ -> do
|
|
stmtDocs <- docHandleComms stmtEpAnn $ do
|
|
stmts `forM` docHandleListElemComms layoutStmt
|
|
docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
|
|
(docLit $ Text.pack "mdo")
|
|
(docSetBaseAndIndent
|
|
$ docNonBottomSpacing
|
|
$ docLines
|
|
$ pure <$> stmtDocs
|
|
)
|
|
x
|
|
| case x of
|
|
ListComp -> True
|
|
MonadComp -> True
|
|
_ -> False
|
|
-> do
|
|
stmtDocs <- docHandleComms stmtEpAnn $
|
|
stmts `forM` docHandleListElemComms layoutStmt
|
|
let hasComments = hasAnyCommentsBelow lexpr
|
|
runFilteredAlternative $ do
|
|
addAlternativeCond (not hasComments) $ docSeq
|
|
[ -- TODO92 docNodeAnnKW lexpr Nothing $
|
|
appSep $ docLit $ Text.pack "["
|
|
, -- TODO92 docNodeAnnKW lexpr (Just AnnOpenS) $
|
|
appSep
|
|
$ docForceSingleline
|
|
$ pure (List.last stmtDocs)
|
|
, appSep $ docLit $ Text.pack "|"
|
|
, docSeq
|
|
$ List.intersperse docCommaSep
|
|
$ (docForceSingleline . pure) <$> List.init stmtDocs
|
|
, docLit $ Text.pack " ]"
|
|
]
|
|
addAlternative
|
|
$ let
|
|
start = docCols
|
|
ColListComp
|
|
[ -- TODO92 docNodeAnnKW lexpr Nothing $
|
|
appSep $ docLit $ Text.pack "["
|
|
, docSetBaseY
|
|
-- TODO92 $ docNodeAnnKW lexpr (Just AnnOpenS)
|
|
$ pure (List.last stmtDocs)
|
|
]
|
|
(s1, sM) = case List.init stmtDocs of
|
|
(a: b) -> (a, b)
|
|
_ -> error "layoutExp: stmtDocs list too short"
|
|
line1 =
|
|
docCols ColListComp [appSep $ docLit $ Text.pack "|", pure s1]
|
|
lineM = sM <&> \d -> docCols ColListComp [docCommaSep, pure d]
|
|
end = docLit $ Text.pack "]"
|
|
in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end]
|
|
_ -> do
|
|
-- TODO
|
|
unknownNodeError "HsDo{} unknown stmtCtx" lexpr
|
|
ExplicitList listEpAnn elems@(_ : _) -> docHandleComms listEpAnn $ do
|
|
let posOpen = obtainAnnPos listEpAnn AnnOpenS
|
|
let posClose = obtainAnnPos listEpAnn AnnCloseS
|
|
let openDoc = docHandleComms posOpen $ docLitS "["
|
|
let closeDoc = docHandleComms posClose $ docLitS "]"
|
|
elemDocs <- elems `forM` (shareDoc . docHandleListElemComms layoutExpr)
|
|
let hasComments = hasAnyCommentsBelow lexpr
|
|
case splitFirstLast elemDocs of
|
|
FirstLastEmpty -> docSeq
|
|
[ docLit $ Text.pack "["
|
|
, closeDoc
|
|
]
|
|
FirstLastSingleton e -> docAlt
|
|
[ docSeq
|
|
[ openDoc
|
|
, docForceSingleline e
|
|
, closeDoc
|
|
]
|
|
, docSetBaseY $ docLines
|
|
[ docSeq
|
|
[ openDoc
|
|
, docSeparator
|
|
, docSetBaseY $ e
|
|
]
|
|
, closeDoc
|
|
]
|
|
]
|
|
FirstLast e1 ems eN -> runFilteredAlternative $ do
|
|
addAlternativeCond (not hasComments)
|
|
$ docSeq
|
|
$ [openDoc]
|
|
++ List.intersperse
|
|
docCommaSep
|
|
(docForceSingleline
|
|
<$> (e1 : ems ++ [eN])
|
|
)
|
|
++ [closeDoc]
|
|
addAlternative
|
|
$ let
|
|
start = docCols ColList [appSep $ openDoc, e1]
|
|
linesM = ems <&> \d -> docCols ColList [docCommaSep, d]
|
|
lineN = docCols
|
|
ColList
|
|
[docCommaSep, eN]
|
|
in docSetBaseY $
|
|
docLines $ [start] ++ linesM ++ [lineN] ++ [closeDoc]
|
|
ExplicitList epAnn [] -> docHandleComms epAnn $ docLit $ Text.pack "[]"
|
|
RecordCon epAnn lname fields -> docHandleComms epAnn $ do
|
|
let (wrapOpen, wrapClose) = case epAnn of
|
|
EpAnn _ [open, close] _ ->
|
|
( docHandleComms (obtainAnnPos open AnnOpenC)
|
|
, docHandleComms (obtainAnnPos close AnnCloseC)
|
|
)
|
|
_ -> (id, id)
|
|
fieldLayouter = \case
|
|
FieldOcc _ lnameF -> docLit (lrdrNameToText lnameF)
|
|
XFieldOcc _ -> error "XFieldOcc"
|
|
case fields of
|
|
HsRecFields fs Nothing -> do
|
|
let nameDoc = docHandleComms lname $ docLit $ lrdrNameToText lname
|
|
recordExpression False wrapOpen id wrapClose indentPolicy lexpr nameDoc fieldLayouter fs
|
|
HsRecFields [] (Just (L dotdotLoc 0)) -> do
|
|
let wrapDotDot = docHandleComms dotdotLoc
|
|
let t = lrdrNameToText lname
|
|
docHandleComms lname $ docSeq
|
|
[ docLit t
|
|
, docSeparator
|
|
, wrapOpen $ docLitS "{"
|
|
, docSeparator
|
|
, wrapDotDot $ docLitS ".."
|
|
, docSeparator
|
|
, wrapClose $ docLitS "}"
|
|
]
|
|
HsRecFields fs@(_ : _) (Just (L dotdotLoc dotdoti)) | dotdoti == length fs -> do
|
|
let nameDoc = docHandleComms lname $ docLit $ lrdrNameToText lname
|
|
let wrapDotDot = docHandleComms dotdotLoc
|
|
recordExpression True wrapOpen wrapDotDot wrapClose indentPolicy lexpr nameDoc fieldLayouter fs
|
|
_ -> unknownNodeError "RecordCon with puns" lexpr
|
|
RecordUpd epAnn rExpr (Left fields) -> docHandleComms epAnn $ do
|
|
let (wrapOpen, wrapClose) = case epAnn of
|
|
EpAnn _ [open, close] _ ->
|
|
( docHandleComms $ obtainAnnPos open AnnOpenC
|
|
, docHandleComms $ obtainAnnPos close AnnCloseC
|
|
)
|
|
_ -> (id, id)
|
|
let fieldLayouter = \case
|
|
Unambiguous _ n -> docLit (lrdrNameToText n)
|
|
Ambiguous _ n -> docLit (lrdrNameToText n)
|
|
XAmbiguousFieldOcc _ -> error "XAmbiguousFieldOcc"
|
|
rExprDoc <- shareDoc $ layoutExpr rExpr
|
|
recordExpression False wrapOpen id wrapClose indentPolicy lexpr rExprDoc fieldLayouter fields
|
|
RecordUpd epAnn rExpr (Right fields) -> do
|
|
let (wrapOpen, wrapClose) = case epAnn of
|
|
EpAnn _ [open, close] _ ->
|
|
( docHandleComms $ obtainAnnPos open AnnOpenC
|
|
, docHandleComms $ obtainAnnPos close AnnCloseC
|
|
)
|
|
_ -> (id, id)
|
|
rExprDoc <- shareDoc $ layoutExpr rExpr
|
|
let labelLayouter label = case label of
|
|
L flAnn (HsFieldLabel _ (L _ n)) ->
|
|
docHandleComms flAnn $ docLitS $ FastString.unpackFS n
|
|
L _ann (XHsFieldLabel _) -> error "XHsFieldLabel"
|
|
let fieldLayouter = \case
|
|
FieldLabelStrings [] -> docEmpty
|
|
FieldLabelStrings [label] -> labelLayouter label
|
|
FieldLabelStrings labels -> docSeq
|
|
$ List.intersperse docCommaSep
|
|
$ map labelLayouter labels
|
|
recordExpression False wrapOpen id wrapClose indentPolicy lexpr rExprDoc fieldLayouter fields
|
|
ExprWithTySig _ exp1 (HsWC _ typ1) -> do
|
|
expDoc <- shareDoc $ layoutExpr exp1
|
|
typDoc <- shareDoc $ layoutSigType typ1
|
|
docSeq [appSep expDoc, appSep $ docLit $ Text.pack "::", typDoc]
|
|
ArithSeq _ Nothing info -> case info of
|
|
From e1 -> do
|
|
e1Doc <- shareDoc $ layoutExpr e1
|
|
docSeq
|
|
[ docLit $ Text.pack "["
|
|
, appSep $ docForceSingleline e1Doc
|
|
, docLit $ Text.pack "..]"
|
|
]
|
|
FromThen e1 e2 -> do
|
|
e1Doc <- shareDoc $ layoutExpr e1
|
|
e2Doc <- shareDoc $ layoutExpr e2
|
|
docSeq
|
|
[ docLit $ Text.pack "["
|
|
, docForceSingleline e1Doc
|
|
, appSep $ docLit $ Text.pack ","
|
|
, appSep $ docForceSingleline e2Doc
|
|
, docLit $ Text.pack "..]"
|
|
]
|
|
FromTo e1 eN -> do
|
|
e1Doc <- shareDoc $ layoutExpr e1
|
|
eNDoc <- shareDoc $ layoutExpr eN
|
|
docSeq
|
|
[ docLit $ Text.pack "["
|
|
, appSep $ docForceSingleline e1Doc
|
|
, appSep $ docLit $ Text.pack ".."
|
|
, docForceSingleline eNDoc
|
|
, docLit $ Text.pack "]"
|
|
]
|
|
FromThenTo e1 e2 eN -> do
|
|
e1Doc <- shareDoc $ layoutExpr e1
|
|
e2Doc <- shareDoc $ layoutExpr e2
|
|
eNDoc <- shareDoc $ layoutExpr eN
|
|
docSeq
|
|
[ docLit $ Text.pack "["
|
|
, docForceSingleline e1Doc
|
|
, appSep $ docLit $ Text.pack ","
|
|
, appSep $ docForceSingleline e2Doc
|
|
, appSep $ docLit $ Text.pack ".."
|
|
, docForceSingleline eNDoc
|
|
, docLit $ Text.pack "]"
|
|
]
|
|
HsGetField _epAnn _exp1 _field -> do
|
|
let
|
|
labelLayouter label = case label of
|
|
L flAnn (HsFieldLabel _ (L _ n)) ->
|
|
docHandleComms flAnn $ docLitS $ FastString.unpackFS n
|
|
L _ann (XHsFieldLabel _) -> error "XHsFieldLabel"
|
|
gather
|
|
:: [ToBriDocM BriDocNumbered]
|
|
-> LHsExpr GhcPs
|
|
-> (LHsExpr GhcPs, [ToBriDocM BriDocNumbered])
|
|
gather list = \case
|
|
L _ (HsGetField epAnn l r) -> gather
|
|
(docHandleComms epAnn $ labelLayouter r : list) l
|
|
x -> (x, list)
|
|
let (headE, paramEs) = gather
|
|
[]
|
|
lexpr
|
|
expDoc <- shareDoc $ layoutExpr headE
|
|
-- this only has single-line layout, afaik
|
|
docForceSingleline $ docSeq $ intersperse (docLitS ".") (expDoc: paramEs)
|
|
HsProjection epAnn (f1 :| fR) -> do
|
|
let
|
|
labelLayouter label = case label of
|
|
L flAnn (HsFieldLabel _ (L _ n)) ->
|
|
docHandleComms flAnn $ docLitS $ FastString.unpackFS n
|
|
L _ann (XHsFieldLabel _) -> error "XHsFieldLabel"
|
|
docForceSingleline $ docHandleComms epAnn $ docSeq
|
|
( [ docLitS "(" ]
|
|
++ [ doc | f <- f1:fR, doc <- [docLitS ".", labelLayouter f] ]
|
|
++ [ docLitS ")" ]
|
|
)
|
|
ArithSeq{} -> briDocByExactInlineOnly "ArithSeq" lexpr
|
|
HsBracket{} -> do
|
|
-- TODO
|
|
briDocByExactInlineOnly "HsBracket{}" lexpr
|
|
HsRnBracketOut{} -> do
|
|
-- TODO
|
|
briDocByExactInlineOnly "HsRnBracketOut{}" lexpr
|
|
HsTcBracketOut{} -> do
|
|
-- TODO
|
|
briDocByExactInlineOnly "HsTcBracketOut{}" lexpr
|
|
HsSpliceE _ (HsQuasiQuote _ _ quoter _loc content) -> do
|
|
allocateNode $ BDPlain
|
|
(Text.pack
|
|
$ "["
|
|
++ showOutputable quoter
|
|
++ "|"
|
|
++ showOutputable content
|
|
++ "|]"
|
|
)
|
|
HsSpliceE{} -> do
|
|
-- TODO
|
|
briDocByExactInlineOnly "HsSpliceE{}" lexpr
|
|
HsProc{} -> do
|
|
-- TODO
|
|
briDocByExactInlineOnly "HsProc{}" lexpr
|
|
HsStatic{} -> do
|
|
-- TODO
|
|
briDocByExactInlineOnly "HsStatic{}" lexpr
|
|
HsTick{} -> do
|
|
-- TODO
|
|
briDocByExactInlineOnly "HsTick{}" lexpr
|
|
HsBinTick{} -> do
|
|
-- TODO
|
|
briDocByExactInlineOnly "HsBinTick{}" lexpr
|
|
HsConLikeOut{} -> do
|
|
-- TODO
|
|
briDocByExactInlineOnly "HsWrap{}" lexpr
|
|
ExplicitSum{} -> do
|
|
-- TODO
|
|
briDocByExactInlineOnly "ExplicitSum{}" lexpr
|
|
HsPragE{} -> do
|
|
-- TODO
|
|
briDocByExactInlineOnly "HsPragE{}" lexpr
|
|
|
|
recordExpression
|
|
:: Bool
|
|
-> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered)
|
|
-> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered)
|
|
-> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered)
|
|
-> IndentPolicy
|
|
-> LocatedA lExpr
|
|
-> ToBriDocM BriDocNumbered
|
|
-> (field -> ToBriDocM BriDocNumbered)
|
|
-- -> [LHsFieldBind GhcPs (LFieldOcc p) (LHsExpr GhcPs)]
|
|
-> [LHsRecField' GhcPs field (LHsExpr GhcPs)]
|
|
-> ToBriDocM BriDocNumbered
|
|
recordExpression False wrapO _wrapDD wrapC _ _lexpr nameDoc _ [] = docSeq
|
|
[ -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC) $
|
|
docSeq [nameDoc, wrapO $ docLit $ Text.pack "{"]
|
|
, wrapC $ docLit $ Text.pack "}"
|
|
]
|
|
recordExpression True wrapO wrapDD wrapC _ _lexpr nameDoc _ [] = docSeq -- this case might still be incomplete, and is probably not used
|
|
-- atm anyway.
|
|
[ nameDoc
|
|
, wrapO $ docLit $ Text.pack "{"
|
|
, docSeparator
|
|
, wrapDD $ docLitS ".."
|
|
, docSeparator
|
|
, wrapC $ docLit $ Text.pack "}"
|
|
]
|
|
recordExpression dotdot wrapO wrapDD wrapC indentPolicy _lexpr nameDoc nameLayouter (rF1 : rFr) = do
|
|
let mkFieldTuple = \case
|
|
L srcSpan (HsRecField fEpAnn (L _ nameThing) rFExpr pun) -> do
|
|
let (posStart, _posSomething) = case fEpAnn of -- TODO92 not sure what posSomething is
|
|
EpAnn anch [AddEpAnn _ span] _ ->
|
|
( Just $ GHC.realSrcSpanStart $ anchor anch
|
|
, Just $ epaLocationRealSrcSpanStart span
|
|
)
|
|
_ -> (Nothing, Nothing)
|
|
let posComma = case srcSpan of
|
|
SrcSpanAnn (EpAnn _ (AnnListItem items) _) _ -> case items of
|
|
[AddCommaAnn span] -> Just $ epaLocationRealSrcSpanStart span
|
|
_ -> Nothing
|
|
SrcSpanAnn EpAnnNotUsed _ -> Nothing
|
|
fnameDoc <- shareDoc $ nameLayouter nameThing
|
|
if pun
|
|
then pure $ Left (posStart, fnameDoc)
|
|
else do
|
|
expDoc <- shareDoc $ docFlushCommsPost posComma $ layoutExpr rFExpr
|
|
pure $ Right (posStart, fnameDoc, expDoc)
|
|
fieldTuple1 <- mkFieldTuple rF1
|
|
fieldTupleR <- rFr `forM` mkFieldTuple
|
|
let fieldWiths
|
|
:: a
|
|
-> a
|
|
-> ( a
|
|
-> Either
|
|
(Maybe GHC.RealSrcLoc, ToBriDocM BriDocNumbered)
|
|
( Maybe GHC.RealSrcLoc
|
|
, ToBriDocM BriDocNumbered
|
|
, ToBriDocM BriDocNumbered
|
|
)
|
|
-> ToBriDocM BriDocNumbered
|
|
)
|
|
-> [ToBriDocM BriDocNumbered]
|
|
fieldWiths extra1 extraR f =
|
|
f extra1 fieldTuple1 : map (f extraR) fieldTupleR
|
|
runFilteredAlternative $ do
|
|
-- container { fieldA = blub, fieldB = blub }
|
|
addAlternative $ docSeq
|
|
[ -- TODO92 docNodeAnnKW lexpr Nothing $
|
|
appSep $ docForceSingleline nameDoc
|
|
, appSep $ wrapO $ docLit $ Text.pack "{"
|
|
, docSeq
|
|
$ List.intersperse docCommaSep
|
|
$ fieldWiths () () $ \() -> \case
|
|
Left (pos, fnameDoc) -> docHandleComms pos $ fnameDoc
|
|
Right (pos, fnameDoc, expDoc) -> docHandleComms pos $ docSeq
|
|
[ appSep $ fnameDoc
|
|
, appSep $ docLit $ Text.pack "="
|
|
, docForceSingleline $ expDoc
|
|
]
|
|
, if dotdot
|
|
then docSeq [docCommaSep, wrapDD $ docLit $ Text.pack "..", docSeparator]
|
|
else docSeparator
|
|
, wrapC $ docLit $ Text.pack "}"
|
|
]
|
|
-- hanging single-line fields
|
|
-- container { fieldA = blub
|
|
-- , fieldB = blub
|
|
-- }
|
|
addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq
|
|
[ -- TODO92 docNodeAnnKW lexpr Nothing $
|
|
docForceSingleline $ appSep nameDoc
|
|
, docSetBaseY
|
|
$ docLines
|
|
$ let
|
|
fieldLines = fieldWiths
|
|
(appSep $ wrapO $ docLit $ Text.pack "{")
|
|
docCommaSep
|
|
$ \prep -> \case
|
|
Left (pos, fnameDoc) -> docCols
|
|
ColRec
|
|
[ prep
|
|
, docHandleComms pos $ fnameDoc
|
|
]
|
|
Right (pos, fnameDoc, expDoc) -> docCols
|
|
ColRec
|
|
[ prep
|
|
, docHandleComms pos $ appSep $ fnameDoc
|
|
, docSeq
|
|
[appSep $ docLit $ Text.pack "=", docForceSingleline expDoc]
|
|
]
|
|
dotdotLine = if dotdot
|
|
then docCols
|
|
ColRec
|
|
[ -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC)
|
|
docCommaSep
|
|
, wrapDD $ docLit $ Text.pack ".."
|
|
]
|
|
else -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC)
|
|
docEmpty
|
|
lineN = wrapC $ docLit $ Text.pack "}"
|
|
in fieldLines ++ [dotdotLine, lineN]
|
|
]
|
|
-- non-hanging with expressions placed to the right of the names
|
|
-- container
|
|
-- { fieldA = blub
|
|
-- , fieldB = potentially
|
|
-- multiline
|
|
-- }
|
|
addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
|
|
(-- TODO92 docNodeAnnKW lexpr Nothing
|
|
nameDoc)
|
|
(docNonBottomSpacing
|
|
$ docLines
|
|
$ let
|
|
fieldLines = fieldWiths
|
|
(appSep $ wrapO $ docLit $ Text.pack "{")
|
|
docCommaSep
|
|
$ \prep -> \case
|
|
Left (pos, fnameDoc) -> docCols ColRec
|
|
[ prep
|
|
, docHandleComms pos $ fnameDoc
|
|
]
|
|
Right (pos, fnameDoc, expDoc) -> docCols ColRec
|
|
[ prep
|
|
, docHandleComms pos $ appSep $ fnameDoc
|
|
, runFilteredAlternative $ do
|
|
addAlternativeCond (indentPolicy == IndentPolicyFree) $ do
|
|
docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY expDoc]
|
|
addAlternative $ do
|
|
docSeq
|
|
[appSep $ docLit $ Text.pack "=", docForceParSpacing expDoc]
|
|
addAlternative $ do
|
|
docAddBaseY BrIndentRegular
|
|
$ docPar (docLit $ Text.pack "=") expDoc
|
|
]
|
|
dotdotLine = if dotdot
|
|
then docCols
|
|
ColRec
|
|
[ -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC)
|
|
docCommaSep
|
|
, wrapDD $ docLit $ Text.pack ".."
|
|
]
|
|
else -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC)
|
|
docEmpty
|
|
lineN = wrapC $ docLit $ Text.pack "}"
|
|
in fieldLines ++ [dotdotLine, lineN]
|
|
)
|
|
|
|
litBriDoc :: HsLit GhcPs -> BriDocWrapped
|
|
litBriDoc = \case
|
|
HsChar (SourceText t) _c -> BDLit $ Text.pack t -- BDLit $ Text.pack $ ['\'', c, '\'']
|
|
HsCharPrim (SourceText t) _c -> BDLit $ Text.pack t -- BDLit $ Text.pack $ ['\'', c, '\'']
|
|
HsString (SourceText t) _fastString -> BDLit $ Text.pack t -- BDLit $ Text.pack $ FastString.unpackFS fastString
|
|
HsStringPrim (SourceText t) _byteString -> BDLit $ Text.pack t -- BDLit $ Text.pack $ Data.ByteString.Char8.unpack byteString
|
|
HsInt _ (IL (SourceText t) _ _) -> BDLit $ Text.pack t -- BDLit $ Text.pack $ show i
|
|
HsIntPrim (SourceText t) _i -> BDLit $ Text.pack t -- BDLit $ Text.pack $ show i
|
|
HsWordPrim (SourceText t) _i -> BDLit $ Text.pack t -- BDLit $ Text.pack $ show i
|
|
HsInt64Prim (SourceText t) _i -> BDLit $ Text.pack t -- BDLit $ Text.pack $ show i
|
|
HsWord64Prim (SourceText t) _i -> BDLit $ Text.pack t -- BDLit $ Text.pack $ show i
|
|
HsInteger (SourceText t) _i _type -> BDLit $ Text.pack t -- BDLit $ Text.pack $ show i
|
|
HsRat _ (FL (SourceText t) _ _ _ _) _type -> BDLit $ Text.pack t
|
|
HsFloatPrim _ (FL (SourceText t) _ _ _ _) -> BDLit $ Text.pack t
|
|
HsDoublePrim _ (FL (SourceText t) _ _ _ _) -> BDLit $ Text.pack t
|
|
_ -> error "litBriDoc: literal with no SourceText"
|
|
|
|
overLitValBriDoc :: OverLitVal -> BriDocWrapped
|
|
overLitValBriDoc = \case
|
|
HsIntegral (IL (SourceText t) _ _) -> BDLit $ Text.pack t
|
|
HsFractional (FL (SourceText t) _ _ _ _) -> BDLit $ Text.pack t
|
|
HsIsString (SourceText t) _ -> BDLit $ Text.pack t
|
|
_ -> error "overLitValBriDoc: literal with no SourceText"
|