1150 lines
46 KiB
Haskell
1150 lines
46 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.Hs
|
|
import qualified GHC.OldList as List
|
|
import GHC.Types.Basic
|
|
import GHC.Types.Name
|
|
import GHC.Types.SourceText ( FractionalLit(FL)
|
|
, IntegralLit(IL)
|
|
, SourceText(SourceText)
|
|
)
|
|
import qualified GHC.Types.SrcLoc as GHC
|
|
|
|
import Language.Haskell.Brittany.Internal.Components.BriDoc
|
|
import Language.Haskell.Brittany.Internal.Config.Types
|
|
import Language.Haskell.Brittany.Internal.Prelude
|
|
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
|
|
import Language.Haskell.Brittany.Internal.Types
|
|
import Language.Haskell.Brittany.Internal.Utils
|
|
|
|
|
|
|
|
layoutExpr :: ToBriDoc HsExpr
|
|
layoutExpr lexpr@(L _ expr) = do
|
|
indentPolicy <- askLayoutConf _lconfig_indentPolicy
|
|
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)]) _)
|
|
| Match epAnn _matchCtx pats (GRHSs _ [lgrhs] llocals) <- match
|
|
, EmptyLocalBinds{} <- llocals
|
|
, L _ (GRHS rhsEpAnn [] body) <- lgrhs
|
|
-> do
|
|
layouters <- mAsk
|
|
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 <- callLayouter layout_pat p
|
|
fixed <- case Seq.viewl patDocSeq of
|
|
p1 Seq.:< pr | shouldPrefixSeparator -> do
|
|
p1' <- docSeq [docSeparator, pure p1]
|
|
pure (p1' Seq.<| pr)
|
|
_ -> pure patDocSeq
|
|
layout_colsWrapPat layouters fixed
|
|
bodyDoc <-
|
|
shareDoc
|
|
$ docAddBaseY BrIndentRegular
|
|
$ docHandleComms epAnn
|
|
$ docHandleComms rhsEpAnn
|
|
$ 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 epAnn (MG _ lmatches@(L _ matches) _) -> do
|
|
binderDoc <- docLit $ Text.pack "->"
|
|
layouters <- mAsk
|
|
funcPatDocs <-
|
|
layout_patternBind layouters Nothing binderDoc `mapM` matches
|
|
docSetParSpacing
|
|
$ docAddBaseY BrIndentRegular
|
|
$ docHandleComms epAnn
|
|
$ docPar
|
|
(docLit $ Text.pack "\\case")
|
|
( docSetBaseAndIndent
|
|
$ docNonBottomSpacing
|
|
$ docHandleComms lmatches
|
|
$ 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
|
|
(_, L _ HsDo{}) -> True
|
|
(_, L _ HsSpliceE{}) -> 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 $ callLayouter2 layout_type False ty1
|
|
e <- shareDoc $ callLayouter layout_expr exp1
|
|
docAlt
|
|
[ docSeq
|
|
[ docForceSingleline e
|
|
, docSeparator
|
|
, docLit $ Text.pack "@"
|
|
, docForceSingleline t
|
|
]
|
|
, docPar e (docSeq [docLit $ Text.pack "@", t])
|
|
]
|
|
OpApp _topEpAnn _expLeft _expOp _expRight -> do
|
|
-- let
|
|
-- allowPar = case (expOp, expRight) of
|
|
-- (L _ (HsVar _ (L _ (Unqual occname))), _)
|
|
-- | occNameString occname == "$" -> True
|
|
-- (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False
|
|
-- _ -> True
|
|
-- let hasComments =
|
|
-- not
|
|
-- $ hasAnyCommentsConnected expLeft
|
|
-- || hasAnyCommentsConnected expOp
|
|
layouters <- mAsk
|
|
treeAndHasComms <-
|
|
layout_gatherOpTreeE layouters NoParen False id Nothing Nothing [] lexpr
|
|
layout_opTree layouters treeAndHasComms
|
|
NegApp _ op _ -> do
|
|
opDoc <- shareDoc $ layoutExpr op
|
|
docSeq [docLit $ Text.pack "-", opDoc]
|
|
HsPar _epAnn _inner -> do
|
|
layouters <- mAsk
|
|
treeAndHasComms <-
|
|
layout_gatherOpTreeE layouters NoParen False id Nothing Nothing [] lexpr
|
|
layout_opTree layouters treeAndHasComms
|
|
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, docSetBaseY e1]
|
|
linesM = ems <&> \d -> docCols ColTuples [docCommaSep, docSetBaseY d]
|
|
lineN = docCols
|
|
ColTuples
|
|
[ docCommaSep
|
|
, -- TODO92 docNodeAnnKW lexpr (Just AnnOpenP)
|
|
docSetBaseY 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 "->"
|
|
layouters <- mAsk
|
|
funcPatDocs <-
|
|
-- docWrapNode lmatches
|
|
layout_patternBind layouters 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 $ docPar
|
|
(docAddBaseY maySpecialIndent $ docSeq [appSep $ ifDoc, ifExprDoc])
|
|
(docLines
|
|
[ docAddBaseY BrIndentRegular $ docAlt
|
|
[ docSeq [appSep $ thenDoc, docForceParSpacing thenExprDoc]
|
|
, docPar thenDoc thenExprDoc
|
|
]
|
|
, docAddBaseY BrIndentRegular $ docAlt
|
|
[ docSeq [appSep $ elseDoc, docForceParSpacing elseExprDoc]
|
|
, 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
|
|
layouters <- mAsk
|
|
docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
|
|
(docHandleComms posIf $ docLit $ Text.pack "if")
|
|
(layout_patternBindFinal layouters
|
|
Nothing
|
|
binderDoc
|
|
Nothing
|
|
(Right cases)
|
|
(id, 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
|
|
(wrapBinds, mBindDocs) <- callLayouter layout_localBinds 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
|
|
$ docFlushCommsPost True spanLet
|
|
$ wrapLet
|
|
$ docLitS "let"
|
|
inDoc <- shareDoc $ wrapIn $ docLit $ Text.pack "in"
|
|
docSetBaseAndIndent $ case fmap snd mBindDocs of
|
|
Just [bindDoc] -> runFilteredAlternative $ do
|
|
addAlternativeCond (not hasComments) $ docSeq
|
|
[ appSep $ letDoc
|
|
, wrapBinds $ appSep $ docForceSingleline (pure bindDoc)
|
|
, appSep $ inDoc
|
|
, docForceSingleline expDoc1
|
|
]
|
|
addAlternative $ docLines
|
|
[ docAlt
|
|
[ docSeq
|
|
[ appSep $ letDoc
|
|
, wrapBinds
|
|
$ ifIndentFreeElse docSetBaseAndIndent docForceSingleline
|
|
$ pure bindDoc
|
|
]
|
|
, docAddBaseY BrIndentRegular $ docPar
|
|
(letDoc)
|
|
(wrapBinds $ 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)
|
|
( wrapBinds
|
|
$ 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
|
|
[ docSeq
|
|
[ appSep $ letDoc
|
|
, wrapBinds $ docSetBaseAndIndent $ docLines $ pure <$> bindDocs
|
|
]
|
|
, docSeq
|
|
[ appSep $ wrapIn $ docLit $ Text.pack "in "
|
|
, docSetBaseY expDoc1
|
|
]
|
|
]
|
|
addAlternative $ docLines
|
|
[ docAddBaseY BrIndentRegular $ docPar
|
|
(letDoc)
|
|
(wrapBinds $ docSetBaseAndIndent $ docLines $ pure <$> bindDocs)
|
|
, docAddBaseY BrIndentRegular
|
|
$ docPar (inDoc) (docSetBaseY $ expDoc1)
|
|
]
|
|
_ -> docSeq
|
|
[ docForceSingleline $ docSeq
|
|
[letDoc, docSeparator, wrapBinds $ inDoc]
|
|
, docSeparator
|
|
, expDoc1
|
|
]
|
|
-- docSeq [appSep $ docLit "let in", expDoc1]
|
|
HsDo epAnn stmtCtx (L (SrcSpanAnn stmtEpAnn _) stmts) ->
|
|
docHandleComms epAnn $ do
|
|
case stmtCtx of
|
|
DoExpr _ -> do
|
|
let locDo = obtainAnnPos epAnn AnnDo
|
|
stmtDocs <- docHandleComms stmtEpAnn $ do
|
|
stmts `forM` docHandleListElemComms (callLayouter layout_stmt)
|
|
docSetParSpacing $ docAddBaseY BrIndentRegularForce $ docPar
|
|
( docFlushCommsPost True locDo
|
|
$ docHandleComms locDo
|
|
$ docLit
|
|
$ Text.pack "do"
|
|
)
|
|
( docSetBaseAndIndent
|
|
$ docNonBottomSpacing
|
|
$ docLines
|
|
$ (pure <$> stmtDocs)
|
|
)
|
|
MDoExpr _ -> do
|
|
stmtDocs <- docHandleComms stmtEpAnn $ do
|
|
stmts `forM` docHandleListElemComms (callLayouter layout_stmt)
|
|
docSetParSpacing $ docAddBaseY BrIndentRegularForce $ 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 (callLayouter layout_stmt)
|
|
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 <- docHandleListElemCommsProperPost layoutExpr elems
|
|
let hasComments = hasAnyCommentsBelow lexpr
|
|
case splitFirstLast elemDocs of
|
|
FirstLastEmpty -> docSeq [docLit $ Text.pack "[", closeDoc]
|
|
FirstLastSingleton (_, ast, e) -> docAlt
|
|
[ docSeq [openDoc, docForceSingleline e, closeDoc]
|
|
, docSetBaseY $ docLines
|
|
[ docSeq
|
|
[ openDoc
|
|
, docSeparator
|
|
, docSetBaseY $ docFlushCommsPost True ast e
|
|
]
|
|
, closeDoc
|
|
]
|
|
]
|
|
FirstLast (_, _, e1) ems (finalCommaPos, _, eN) -> runFilteredAlternative $ do
|
|
addAlternativeCond (not hasComments)
|
|
$ docSeq
|
|
$ [openDoc, docForceSingleline e1]
|
|
++ [ x
|
|
| (commaPos, _, e) <- ems
|
|
, x <- [docHandleComms commaPos docCommaSep, docForceSingleline e]
|
|
]
|
|
++ [ docHandleComms finalCommaPos docCommaSep
|
|
, docForceSingleline eN
|
|
, closeDoc]
|
|
addAlternative
|
|
$ let start = docCols ColList [appSep $ openDoc, e1]
|
|
linesM = ems <&> \(p, ast, d) ->
|
|
docCols
|
|
ColList
|
|
[ docHandleComms p docCommaSep
|
|
, docFlushCommsPost True ast $ d
|
|
]
|
|
lineN = docCols ColList
|
|
[docHandleComms finalCommaPos $ 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 $ callLayouter layout_expr exp1
|
|
typDoc <- shareDoc $ callLayouter layout_sigType 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 $ docHandleComms fEpAnn $ nameLayouter nameThing
|
|
if pun
|
|
then pure $ Left (posStart, fnameDoc)
|
|
else do
|
|
expDoc <-
|
|
shareDoc $ docFlushCommsPost True 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"
|