{-# 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 _ (MG _ lmatches@(L _ matches) _) -> do binderDoc <- docLit $ Text.pack "->" layouters <- mAsk funcPatDocs <- layout_patternBind layouters Nothing binderDoc `mapM` matches docSetParSpacing $ docAddBaseY BrIndentRegular $ 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 _ -> 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 $ callLayouter layout_type 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@(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 hasComments = -- not -- $ hasAnyCommentsConnected expLeft -- || hasAnyCommentsConnected expOp layouters <- mAsk treeAndHasComms <- layout_gatherOpTreeE layouters False False id Nothing Nothing [] lexpr layout_opTree layouters treeAndHasComms 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 (L _ (OpApp _topEpAnn _expLeft _expOp _)) -> do -- let innerHasComments = -- not -- $ hasAnyCommentsConnected expLeft -- || hasAnyCommentsConnected expOp -- let AnnParen _ spanOpen spanClose = anns epAnn -- docHandleComms epAnn -- $ processOpTree -- lop -- innerHasComments -- True -- (Just $ epaLocationRealSrcSpanStart spanOpen) -- (Just $ epaLocationRealSrcSpanStart spanClose) -- let hasComments = hasAnyCommentsConnected lexpr -- not -- $ hasAnyCommentsConnected expLeft -- || hasAnyCommentsConnected expOp layouters <- mAsk treeAndHasComms <- layout_gatherOpTreeE layouters False False id Nothing Nothing [] lexpr layout_opTree layouters treeAndHasComms 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, 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 $ 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 , 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 [ -- TODO92 docNodeAnnKW lexpr (Just AnnLet) $ docSeq [ appSep $ letDoc , wrapBinds $ docSetBaseAndIndent $ docLines $ pure <$> bindDocs ] , docSeq [ appSep $ wrapIn $ docLit $ Text.pack "in " , docSetBaseY expDoc1 ] ] addAlternative $ docLines [ -- TODO92 docNodeAnnKW lexpr (Just AnnLet) $ 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 (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 (_, e) -> docAlt [ docSeq [openDoc, docForceSingleline e, closeDoc] , docSetBaseY $ docLines [docSeq [openDoc, docSeparator, docSetBaseY $ 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, d) -> docCols ColList [docHandleComms p docCommaSep, 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 $ 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"