{-# 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
:: [ToBriDocM BriDocNumbered]
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, [ToBriDocM BriDocNumbered])
gather list = \case
L _ (HsApp epAnn l r) -> gather
(docHandleComms epAnn $ layoutExpr 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 <- shareDoc `mapM` paramEs
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 $ docSetParSpacing $ 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
$ docLines
$ return
<$> funcPatDocs
)
, docPar
(docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "case") cExpDoc
)
(docAddBaseY BrIndentRegular $ docPar
(docLit $ Text.pack "of")
(docSetBaseAndIndent
$ docNonBottomSpacing
$ 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 _ cases -> do
binderDoc <- docLit $ Text.pack "->"
let hasComments = hasAnyCommentsBelow lexpr
docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
(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"