{-# 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.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
docHandleComms epAnn
$ 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 "in"
, ifIndentFreeElse ( docSetBaseAndIndent
. docEnsureIndent (BrIndentSpecial 1)
. 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"
, docSeparator
, 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
$ docEnsureIndent (BrIndentSpecial 1)
$ 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 _) []) ->
case stmtCtx of
DoExpr _ ->
docHandleComms epAnn $ docHandleComms stmtEpAnn $ docLitS "do"
MDoExpr _ ->
docHandleComms epAnn $ docHandleComms stmtEpAnn $ docLitS "mdo"
ListComp ->
error "brittany internal error: ListCompo with null statements"
MonadComp ->
error "brittany internal error: ListCompo with null statements"
_ -> unknownNodeError "HsDo{} unknown stmtCtx" lexpr
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, docSetBaseY e1]
linesM = ems <&> \(p, ast, d) ->
docCols
ColList
[ docHandleComms p docCommaSep
, docSetBaseY $ docFlushCommsPost True ast $ d
]
lineN = docCols ColList
[docHandleComms finalCommaPos $ docCommaSep, docSetBaseY 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
docAlt
[ docForceSingleline
$ docSeq [appSep expDoc, appSep $ docLitS "::", typDoc]
, docPar expDoc (docSeq [docLitS "::", docSeparator, 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
++ "|]"
)
splice@HsSpliceE{} -> do
-- TODO
let epAnnWithoutCommas = case GHC.getLoc lexpr of
SrcSpanAnn (EpAnn anch (AnnListItem _) comms) srcLoc -> do
SrcSpanAnn (EpAnn anch (AnnListItem []) comms) srcLoc
x@(SrcSpanAnn EpAnnNotUsed _) -> x
briDocByExactInlineOnly "HsSpliceE{}" (L epAnnWithoutCommas splice)
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"