diff --git a/brittany.cabal b/brittany.cabal index c16e1be..c4b4cae 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -136,6 +136,7 @@ library Language.Haskell.Brittany.Internal.ToBriDoc.Pattern Language.Haskell.Brittany.Internal.ToBriDoc.Stmt Language.Haskell.Brittany.Internal.ToBriDoc.Type + Language.Haskell.Brittany.Internal.ToBriDoc Language.Haskell.Brittany.Internal.Components.BriDoc Language.Haskell.Brittany.Internal.Components.Obfuscation Language.Haskell.Brittany.Internal.Components.OpTree diff --git a/source/library/Language/Haskell/Brittany/Internal/Components/OpTree.hs b/source/library/Language/Haskell/Brittany/Internal/Components/OpTree.hs index 1575423..446a52a 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Components/OpTree.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Components/OpTree.hs @@ -5,7 +5,6 @@ module Language.Haskell.Brittany.Internal.Components.OpTree where import Language.Haskell.Brittany.Internal.Prelude import qualified Data.Text as Text -import GHC ( RealSrcLoc ) import GHC.Types.Fixity ( Fixity(Fixity) , FixityDirection ( InfixL @@ -23,20 +22,6 @@ import Language.Haskell.Brittany.Internal.Types -data OpTree - = OpUnknown Bool -- Z paren? - (Maybe RealSrcLoc) -- paren open loc - (Maybe RealSrcLoc) -- paren close loc - OpTree -- left operand - [(BriDocNumbered, BriDocNumbered)] -- list of (next operand, symbol) - | OpKnown Bool -- with paren? - (Maybe RealSrcLoc) -- paren open loc - (Maybe RealSrcLoc) -- paren close loc - Fixity -- only Just after (successful!) lookup phase - OpTree - [(BriDocNumbered, OpTree)] - | OpLeaf BriDocNumbered - displayOpTree :: OpTree -> String displayOpTree = \case OpUnknown p _ _ leftTree rs -> diff --git a/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs b/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs index 0e7b471..0e78fcf 100644 --- a/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs +++ b/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs @@ -45,6 +45,7 @@ import Language.Haskell.Brittany.Internal.ToBriDoc.Module import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Util.AST import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.ToBriDoc (layouters) @@ -87,7 +88,7 @@ processModule traceFunc conf inlineConf parsedModule = do case modHead of HsModule epAnn _layoutInfo Nothing Nothing _ _ _ _ -> do (bd, _) <- - briDocMToPPM + briDocMToPPM layouters $ maybe id docFlushRemaining (srcSpanFileName_maybe loc) @@ -97,7 +98,7 @@ processModule traceFunc conf inlineConf parsedModule = do "brittany internal error: exports without module name" HsModule epAnn _layoutInfo (Just n) les _ _ _ _ -> do (bd, _) <- - briDocMToPPM + briDocMToPPM layouters $ maybe id docFlushRemaining (srcSpanFileName_maybe loc) @@ -106,7 +107,7 @@ processModule traceFunc conf inlineConf parsedModule = do MEImportDecl importDecl immediateAfterComms -> wrapNonDeclToBriDoc $ do (bd, _) <- - briDocMToPPM + briDocMToPPM layouters $ docSeq ( layoutImport importDecl : map commentToDoc immediateAfterComms @@ -215,18 +216,18 @@ ppToplevelDecl decl immediateAfterComms = do exactprintOnly <- mAsk <&> \declConfig -> declConfig & _conf_roundtrip_exactprint_only & confUnpack bd <- fmap fst $ if exactprintOnly - then briDocMToPPM + then briDocMToPPM layouters $ docSeq (briDocByExact decl : map commentToDoc immediateAfterComms) else do let innerDoc = case decl of L (SrcSpanAnn _ (GHC.RealSrcSpan s _)) _ -> docFlushRemaining (GHC.srcSpanFile s) $ layoutDecl decl _ -> layoutDecl decl - (r, errorCount) <- briDocMToPPM + (r, errorCount) <- briDocMToPPM layouters $ docSeq (innerDoc : map commentToDoc immediateAfterComms) if errorCount == 0 then pure (r, 0) - else briDocMToPPM $ briDocByExactNoComment decl + else briDocMToPPM layouters $ briDocByExactNoComment decl ppBriDoc bd False let commCntIn = connectedCommentCount decl commCntOut <- mGet diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc.hs new file mode 100644 index 0000000..046acce --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.ToBriDoc where + + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.ToBriDoc.DataDecl +import Language.Haskell.Brittany.Internal.ToBriDoc.Decl +import Language.Haskell.Brittany.Internal.ToBriDoc.Expr +import Language.Haskell.Brittany.Internal.ToBriDoc.OpTree +import Language.Haskell.Brittany.Internal.ToBriDoc.IE +import Language.Haskell.Brittany.Internal.ToBriDoc.Pattern +import Language.Haskell.Brittany.Internal.ToBriDoc.Stmt +import Language.Haskell.Brittany.Internal.ToBriDoc.Type + +layouters :: Layouters +layouters = Layouters + { layout_expr = layoutExpr + , layout_lit = litBriDoc + , layout_overLit = overLitValBriDoc + , layout_type = layoutType + , layout_sigType = layoutSigType + , layout_stmt = layoutStmt + , layout_gatherOpTreeE = gatherOpTreeE + , layout_gatherOpTreeT = gatherOpTreeT + , layout_opTree = processOpTree + , layout_grhs = layoutGrhs + , layout_pat = layoutPat + , layout_colsWrapPat = colsWrapPat + , layout_patternBind = layoutPatternBind + , layout_patternBindFinal = layoutPatternBindFinal + , layout_localBinds = layoutLocalBinds + , layout_dataDecl = layoutDataDecl + , layout_tyVarBndrs = layoutTyVarBndrs + , layout_tyVarBndrsSingleline = processTyVarBndrsSingleline + , layout_hsTyPats = layoutHsTyPats + , layout_LLIEs = layoutLLIEs + , layout_annAndSepLLIEs = layoutAnnAndSepLLIEs + } diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs index b961ddb..6c6e6d6 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs @@ -8,7 +8,6 @@ import GHC.Hs import qualified GHC.OldList as List import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.S3_ToBriDocTools -import Language.Haskell.Brittany.Internal.ToBriDoc.Type import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Components.BriDoc @@ -223,8 +222,9 @@ layoutDataDecl ltycl declEpAnn name (HsQTvs _ bndrs) pats defn = case defn of layoutHsTyPats :: [LHsTypeArg GhcPs] -> [ToBriDocM BriDocNumbered] layoutHsTyPats pats = pats <&> \case - HsValArg tm -> layoutType tm - HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty] + HsValArg tm -> callLayouter layout_type tm + HsTypeArg _l ty -> + docSeq [docLit $ Text.pack "@", callLayouter layout_type ty] -- we ignore the SourceLoc here.. this LPat not being (L _ Pat{}) change -- is a bit strange. Hopefully this does not ignore any important -- annotations. @@ -233,10 +233,10 @@ layoutHsTyPats pats = pats <&> \case createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered createContextDoc [] = docEmpty createContextDoc [t] = - docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator] + docSeq [callLayouter layout_type t, docSeparator, docLitS "=>", docSeparator] createContextDoc (t1 : tR) = do - t1Doc <- shareDoc $ layoutType t1 - tRDocs <- tR `forM` (shareDoc . layoutType) + t1Doc <- shareDoc $ callLayouter layout_type t1 + tRDocs <- tR `forM` (shareDoc . callLayouter layout_type) docAlt [ docSeq [ docLitS "(" @@ -258,7 +258,7 @@ createBndrDoc bs = do tyVarDocs <- bs `forM` \case (L _ (UserTyVar _ _ext vname)) -> return $ (lrdrNameToText vname, Nothing) (L _ (KindedTyVar _ _ext lrdrName kind)) -> do - d <- shareDoc $ layoutType kind + d <- shareDoc $ callLayouter layout_type kind return $ (lrdrNameToText lrdrName, Just $ d) docSeq $ List.intersperse docSeparator $ tyVarDocs <&> \(vname, mKind) -> case mKind of @@ -297,7 +297,7 @@ derivingClauseDoc (L _ (HsDerivingClause epAnn mStrategy types)) = [ docDeriving , docHandleComms types $ lhsStrategy , docSeparator - , docHandleListElemComms layoutSigType ty -- TODO92 `docHandleRemaining types` here ? + , docHandleListElemComms (callLayouter layout_sigType) ty -- TODO92 `docHandleRemaining types` here ? -- \case -- HsIB _ t -> layoutType t , rhsStrategy @@ -319,7 +319,7 @@ derivingClauseDoc (L _ (HsDerivingClause epAnn mStrategy types)) = , whenMoreThan1Type "(" , docSeq -- TODO92 `docHandleRemaining types` here ? $ List.intersperse docCommaSep - $ ts <&> docHandleListElemComms layoutSigType + $ ts <&> docHandleListElemComms (callLayouter layout_sigType) , docHandleComms posClose $ whenMoreThan1Type ")" , rhsStrategy ] @@ -335,7 +335,7 @@ derivingClauseDoc (L _ (HsDerivingClause epAnn mStrategy types)) = , docSeq [ docHandleComms viaEpAnn $ docLitS " via" , docSeparator - , docHandleListElemComms layoutSigType viaType + , docHandleListElemComms (callLayouter layout_sigType) viaType ] ) @@ -353,23 +353,25 @@ createDetailsDoc consNameStr details = case details of $ docSeq $ List.intersperse docSeparator $ fmap hsScaledThing args - <&> layoutType + <&> callLayouter layout_type ] leftIndented = docSetParSpacing . docAddBaseY BrIndentRegular . docPar (docLit consNameStr) . docLines - $ layoutType + $ callLayouter layout_type <$> fmap hsScaledThing args multiAppended = docSeq [ docLit consNameStr , docSeparator - , docSetBaseY $ docLines $ layoutType <$> fmap hsScaledThing args + , docSetBaseY + $ docLines + $ callLayouter layout_type <$> fmap hsScaledThing args ] multiIndented = docSetBaseY $ docAddBaseY BrIndentRegular $ docPar (docLit consNameStr) - (docLines $ layoutType <$> fmap hsScaledThing args) + (docLines $ callLayouter layout_type <$> fmap hsScaledThing args) case indentPolicy of IndentPolicyLeft -> docAlt [singleLine, leftIndented] IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented] @@ -450,11 +452,11 @@ createDetailsDoc consNameStr details = case details of ] ) InfixCon arg1 arg2 -> docSeq - [ layoutType $ hsScaledThing arg1 + [ callLayouter layout_type $ hsScaledThing arg1 , docSeparator , docLit consNameStr , docSeparator - , layoutType $ hsScaledThing arg2 + , callLayouter layout_type $ hsScaledThing arg2 ] where mkFieldDocs @@ -480,7 +482,7 @@ createNamesAndTypeDoc lField@(L _ (ConDeclField epAnn names t _)) = L _ (FieldOcc _ fieldName) -> docLit =<< lrdrNameToTextAnn fieldName ] - , docFlushCommsPost True posComma (layoutType t) + , docFlushCommsPost True posComma (callLayouter layout_type t) ) where (posStart, posComma) = obtainListElemStartCommaLocs lField diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs index bf1ea81..55b3e31 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs @@ -22,11 +22,6 @@ import qualified GHC import qualified GHC.Types.SrcLoc as GHC import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.S3_ToBriDocTools -import Language.Haskell.Brittany.Internal.ToBriDoc.DataDecl -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.ToBriDoc.Expr -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 qualified Language.Haskell.GHC.ExactPrint as ExactPrint @@ -96,7 +91,7 @@ layoutSig fallback sig = case sig of let posColon = obtainAnnPos addEpAnn AnnDcolon nameStrs <- names `forM` lrdrNameToTextAnn let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs - typeDoc <- shareDoc $ layoutSigType sigTy + typeDoc <- shareDoc $ callLayouter layout_sigType sigTy let hasComments = hasAnyCommentsBelow fallback shouldBeHanging <- mAsk <&> _conf_layout .> _lconfig_hangingTypeSignature .> confUnpack @@ -160,8 +155,8 @@ layoutBind lbind@(L _ bind) = case bind of $ matches `forM` layoutPatternBind (Just idStr) binderDoc return $ Left $ funcPatDocs PatBind _epAnn pat (GRHSs _ grhss whereBinds) ([], []) -> do -- TODO92 are we ignoring something in whereBinds? - patDocs <- colsWrapPat =<< layoutPat pat - mWhereDocs <- layoutLocalBinds $ whereBinds + patDocs <- callLayouter layout_colsWrapPat =<< callLayouter layout_pat pat + mWhereDocs <- layoutLocalBinds whereBinds -- let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey? binderDoc <- docLit $ Text.pack "=" let hasComments = hasAnyCommentsBelow lbind @@ -241,8 +236,8 @@ layoutGrhs (L _ (GRHS epAnn guards body)) = do let posArrow = obtainAnnPos epAnn AnnRarrow guardDocs <- case guards of [] -> pure [] - _ -> docFlushCommsPost False posArrow $ layoutStmt `mapM` guards - bodyDoc <- layoutExpr body + _ -> docFlushCommsPost False posArrow $ callLayouter layout_stmt `mapM` guards + bodyDoc <- callLayouter layout_expr body return (docHandleComms epAnn, guardDocs, bodyDoc) layoutPatternBind @@ -252,7 +247,8 @@ layoutPatternBind -> ToBriDocM BriDocNumbered layoutPatternBind funId binderDoc lmatch@(L _ match) = do let Match epAnn matchCtx pats (GRHSs _ grhss whereBinds) = match - patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p + patDocs <- pats `forM` \p -> + fmap return $ callLayouter layout_colsWrapPat =<< callLayouter layout_pat p let isInfix = isInfixMatch match let matchEndLoc = case GHC.locA $ GHC.getLoc lmatch of GHC.RealSrcSpan s _ -> Just $ GHC.realSrcSpanEnd s @@ -410,7 +406,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauses mWhereDocs hasCo clauseDocs <- case clauses of Left expr -> do - e <- layoutExpr expr + e <- callLayouter layout_expr expr pure [(id, [], e)] Right grhss -> layoutGrhs `mapM` grhss @@ -656,7 +652,7 @@ layoutPatSynBind name patSynDetails patDir rpat = do binderDoc = case patDir of ImplicitBidirectional -> docLit $ Text.pack "=" _ -> docLit $ Text.pack "<-" - body = colsWrapPat =<< layoutPat rpat + body = callLayouter layout_colsWrapPat =<< callLayouter layout_pat rpat whereDoc = docLit $ Text.pack "where" mWhereDocs <- layoutPatSynWhere patDir headDoc <- @@ -775,15 +771,16 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of ] ++ fmap (layoutTyVarBndr True) (hsq_explicit vars) sharedLhs <- shareDoc $ id lhs - typeDoc <- shareDoc $ layoutType typ + typeDoc <- shareDoc $ callLayouter layout_type typ let hasComments = hasAnyCommentsConnected ltycl layoutLhsAndType hasComments sharedLhs (docHandleComms posEqual $ docLit $ Text.pack "=") 1 typeDoc - DataDecl epAnn name tyVars _ dataDefn -> - layoutDataDecl ltycl epAnn name tyVars [] dataDefn + DataDecl epAnn name tyVars _ dataDefn -> do + layouters <- mAsk + layout_dataDecl layouters ltycl epAnn name tyVars [] dataDefn _ -> briDocByExactNoComment ltycl layoutTyVarBndr :: Bool -> ToBriDoc (HsTyVarBndr ()) @@ -798,7 +795,7 @@ layoutTyVarBndr needsSep (L _ bndr) = case bndr of ++ [ docLit $ Text.pack "(" , appSep $ docLit nameStr , appSep . docLit $ Text.pack "::" - , docForceSingleline $ layoutType kind + , docForceSingleline $ callLayouter layout_type kind , docLit $ Text.pack ")" ] @@ -825,6 +822,7 @@ layoutTyFamInstDecl inClass outerNode tfid = do nameStr <- lrdrNameToTextAnn name -- TODO92 needsParens <- hasAnnKeyword outerNode AnnOpenP let needsParens = False + layouters <- mAsk let instanceDoc = docHandleComms posType $ if inClass then docLit $ Text.pack "type" @@ -832,9 +830,10 @@ layoutTyFamInstDecl inClass outerNode tfid = do [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"] makeForallDoc :: [LHsTyVarBndr () GhcPs] -> ToBriDocM BriDocNumbered makeForallDoc bndrs = do - bndrDocs <- layoutTyVarBndrs bndrs + bndrDocs <- callLayouter layout_tyVarBndrs bndrs docSeq - ([docLit (Text.pack "forall")] ++ processTyVarBndrsSingleline bndrDocs + ( [docLit (Text.pack "forall")] + ++ layout_tyVarBndrsSingleline layouters bndrDocs ) lhs = docHandleComms epAnn $ docSeq @@ -842,14 +841,14 @@ layoutTyFamInstDecl inClass outerNode tfid = do ++ [ makeForallDoc foralls | (HsOuterExplicit _ foralls) <- [bndrsMay] ] ++ [ docParenL | needsParens ] ++ [appSep $ docHandleComms name $ docLit nameStr] - ++ intersperse docSeparator (layoutHsTyPats pats) + ++ intersperse docSeparator (layout_hsTyPats layouters pats) ++ [ docParenR | needsParens ] -- TODO92 hasComments <- -- (||) -- <$> hasAnyRegularCommentsConnected outerNode -- <*> hasAnyRegularCommentsRest innerNode let hasComments = hasAnyCommentsConnected outerNode - typeDoc <- shareDoc $ layoutType typ + typeDoc <- shareDoc $ callLayouter layout_type typ layoutLhsAndType hasComments lhs (docHandleComms posEqual $ docLit $ Text.pack "=") 1 typeDoc @@ -941,7 +940,9 @@ layoutClsInst (L declLoc _) cid = do layoutDataFamInstDecl ldfid@(L _ (DataFamInstDecl famEqn)) = docHandleComms ldfid $ case famEqn of FamEqn epAnn tycon bndrs pats Prefix rhs -> do - layoutDataDecl + layouters <- mAsk + layout_dataDecl + layouters (error "Unsupported form of DataFamInstDecl") epAnn tycon diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs index 2c46d05..8473b88 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs @@ -24,13 +24,8 @@ 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.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.Types import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.ToBriDoc.OpTree @@ -59,6 +54,7 @@ layoutExpr lexpr@(L _ expr) = do , 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` @@ -73,13 +69,13 @@ layoutExpr lexpr@(L _ expr) = do L _ LazyPat{} -> isFirst L _ BangPat{} -> isFirst _ -> False - patDocSeq <- layoutPat p + 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 - colsWrapPat fixed + layout_colsWrapPat layouters fixed bodyDoc <- shareDoc $ docAddBaseY BrIndentRegular @@ -130,7 +126,9 @@ layoutExpr lexpr@(L _ expr) = do $ (docLit $ Text.pack "\\case {}") HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- layoutPatternBind Nothing binderDoc `mapM` matches + layouters <- mAsk + funcPatDocs <- + layout_patternBind layouters Nothing binderDoc `mapM` matches docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "\\case") ( docSetBaseAndIndent @@ -211,8 +209,8 @@ layoutExpr lexpr@(L _ expr) = do headDoc (docNonBottomSpacing $ docLines paramDocs) HsAppType _ exp1 (HsWC _ ty1) -> do - t <- shareDoc $ layoutType ty1 - e <- shareDoc $ layoutExpr exp1 + t <- shareDoc $ callLayouter layout_type ty1 + e <- shareDoc $ callLayouter layout_expr exp1 docAlt [ docSeq [ docForceSingleline e @@ -233,8 +231,10 @@ layoutExpr lexpr@(L _ expr) = do -- not -- $ hasAnyCommentsConnected expLeft -- || hasAnyCommentsConnected expOp - treeAndHasComms <- gatherOpTreeE False False id Nothing Nothing [] lexpr - processOpTree treeAndHasComms + 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 @@ -309,8 +309,10 @@ layoutExpr lexpr@(L _ expr) = do -- not -- $ hasAnyCommentsConnected expLeft -- || hasAnyCommentsConnected expOp - treeAndHasComms <- gatherOpTreeE False False id Nothing Nothing [] lexpr - processOpTree treeAndHasComms + 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 @@ -445,9 +447,10 @@ layoutExpr lexpr@(L _ expr) = do docHandleComms epAnn $ do cExpDoc <- shareDoc $ layoutExpr cExp binderDoc <- docLit $ Text.pack "->" + layouters <- mAsk funcPatDocs <- -- docWrapNode lmatches - layoutPatternBind Nothing binderDoc `mapM` matches + layout_patternBind layouters Nothing binderDoc `mapM` matches docAlt [ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docSeq @@ -574,21 +577,23 @@ layoutExpr lexpr@(L _ expr) = do 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") - (layoutPatternBindFinal Nothing - binderDoc - Nothing - (Right cases) - Nothing - hasComments + (layout_patternBindFinal layouters + 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 + mBindDocs <- callLayouter layout_localBinds binds let ifIndentFreeElse :: a -> a -> a ifIndentFreeElse x y = case indentPolicy of IndentPolicyLeft -> y @@ -692,7 +697,7 @@ layoutExpr lexpr@(L _ expr) = do case stmtCtx of DoExpr _ -> do stmtDocs <- docHandleComms stmtEpAnn $ do - stmts `forM` docHandleListElemComms layoutStmt + stmts `forM` docHandleListElemComms (callLayouter layout_stmt) docSetParSpacing $ docAddBaseY BrIndentRegularForce $ docPar (docLit $ Text.pack "do") ( docSetBaseAndIndent @@ -702,7 +707,7 @@ layoutExpr lexpr@(L _ expr) = do ) MDoExpr _ -> do stmtDocs <- docHandleComms stmtEpAnn $ do - stmts `forM` docHandleListElemComms layoutStmt + stmts `forM` docHandleListElemComms (callLayouter layout_stmt) docSetParSpacing $ docAddBaseY BrIndentRegularForce $ docPar (docLit $ Text.pack "mdo") ( docSetBaseAndIndent @@ -720,7 +725,7 @@ layoutExpr lexpr@(L _ expr) = do stmtDocs <- docHandleComms stmtEpAnn $ stmts - `forM` docHandleListElemComms layoutStmt + `forM` docHandleListElemComms (callLayouter layout_stmt) let hasComments = hasAnyCommentsBelow lexpr runFilteredAlternative $ do addAlternativeCond (not hasComments) $ docSeq @@ -893,8 +898,8 @@ layoutExpr lexpr@(L _ expr) = do fieldLayouter fields ExprWithTySig _ exp1 (HsWC _ typ1) -> do - expDoc <- shareDoc $ layoutExpr exp1 - typDoc <- shareDoc $ layoutSigType typ1 + 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 diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs-boot b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs-boot deleted file mode 100644 index 76a6a3c..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs-boot +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.ToBriDoc.Expr where - -import GHC.Hs -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Components.BriDoc - - - -layoutExpr :: ToBriDoc HsExpr - -litBriDoc :: HsLit GhcPs -> BriDocWrapped - -overLitValBriDoc :: OverLitVal -> BriDocWrapped diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/IE.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/IE.hs index c4f3535..a65eb2e 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/IE.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/IE.hs @@ -116,7 +116,6 @@ layoutIE commAst lie@(L _ ie) = docHandleComms lie $ case ie of name <- lrdrNameToTextAnn n docHandleComms loc $ docLit $ Text.pack "type " <> name -data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted -- Helper function to deal with Located lists of LIEs. -- In particular this will also associate documentation -- from the located list that actually belongs to the last IE. diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Import.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Import.hs index 09f4070..b4e035c 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Import.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Import.hs @@ -14,7 +14,6 @@ import GHC.Types.SourceText(SourceText(SourceText, NoSourceText), sl_st) import GHC.Unit.Types (IsBootInterface(..)) import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.S3_ToBriDocTools -import Language.Haskell.Brittany.Internal.ToBriDoc.IE import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Components.BriDoc @@ -37,6 +36,7 @@ layoutImport ldecl@(L _ importD) = docHandleComms ldecl $ case importD of importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + layouters <- mAsk let compact = indentPolicy /= IndentPolicyFree modNameT = Text.pack $ moduleNameString modName @@ -89,16 +89,18 @@ layoutImport ldecl@(L _ importD) = docHandleComms ldecl $ case importD of then docAlt [ docSeq [ hidDoc - , docForceSingleline $ layoutLLIEs True ShouldSortItems llies + , docForceSingleline + $ layout_LLIEs layouters True ShouldSortItems llies ] , let makeParIfHiding = if hiding then docAddBaseY BrIndentRegular . docPar hidDoc else id - in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) + in makeParIfHiding + (layout_LLIEs layouters True ShouldSortItems llies) ] else do - ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies lies + ieDs <- layout_annAndSepLLIEs layouters ShouldSortItems llies lies -- TODO92 docWrapNodeRest llies docHandleComms llies $ docEnsureIndent (BrIndentSpecial hidDocCol) $ case ieDs of diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Module.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Module.hs index eb497b5..b8f7537 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Module.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Module.hs @@ -14,7 +14,6 @@ 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.ToBriDoc.IE import Language.Haskell.Brittany.Internal.Types @@ -40,13 +39,14 @@ moduleNameExportBridoc epAnn modName les = do Just SameLine{} -> id Just (DifferentLine 0 _) -> id Just dp -> docAddEntryDelta dp + layouters <- mAsk docHandleComms epAnn $ docHandleComms posModule $ runFilteredAlternative $ do addAlternativeCond allowSingleLine $ docSeq [ appSep $ wrapModule $ docLit $ Text.pack "module" , appSep $ docLit tn , docForceSingleline $ appSep $ case les of Nothing -> docEmpty - Just x -> layoutLLIEs True KeepItemsUnsorted x + Just x -> layout_LLIEs layouters True KeepItemsUnsorted x , docSeparator , docHandleComms posWhere $ docLit $ Text.pack "where" ] @@ -58,7 +58,7 @@ moduleNameExportBridoc epAnn modName les = do (docSeq [ case les of Nothing -> docEmpty - Just x -> layoutLLIEs False KeepItemsUnsorted x + Just x -> layout_LLIEs layouters False KeepItemsUnsorted x , docSeparator , docHandleComms posWhere $ docLit $ Text.pack "where" ] diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/OpTree.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/OpTree.hs index 273c569..0d2b994 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/OpTree.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/OpTree.hs @@ -15,8 +15,6 @@ 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 -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.ToBriDoc.Expr -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.ToBriDoc.Type gatherOpTreeE @@ -36,7 +34,11 @@ gatherOpTreeE hasParen hasComms commWrap locOpen locClose opExprList = \case commWrap locOpen locClose - ((docHandleComms epAnn $ layoutExpr op1, layoutExpr r1) : opExprList) + ( ( docHandleComms epAnn $ callLayouter layout_expr op1 + , callLayouter layout_expr r1 + ) + : opExprList + ) l1 (L _ (HsPar epAnn inner)) -> do let AnnParen _ spanOpen spanClose = anns epAnn @@ -63,7 +65,7 @@ gatherOpTreeE hasParen hasComms commWrap locOpen locClose opExprList = \case , innerHasComms ) final -> do - numberedLeft <- commWrap $ layoutExpr final + numberedLeft <- commWrap $ callLayouter layout_expr final numberedRights <- opExprList `forM` \(x, y) -> do x' <- x y' <- y @@ -94,7 +96,7 @@ gatherOpTreeT hasParen hasComms commWrap locOpen locClose opExprList = \case commWrap locOpen locClose - ((docLit $ printRdrNameWithAnns op1, layoutType r1) : opExprList) + ((docLit $ printRdrNameWithAnns op1, callLayouter layout_type r1) : opExprList) l1 (L _ (HsParTy epAnn inner)) -> do let AnnParen _ spanOpen spanClose = anns epAnn @@ -121,7 +123,7 @@ gatherOpTreeT hasParen hasComms commWrap locOpen locClose opExprList = \case , innerHasComms ) final -> do - numberedLeft <- commWrap $ layoutType final + numberedLeft <- commWrap $ callLayouter layout_type final numberedRights <- opExprList `forM` \(x, y) -> do x' <- x y' <- y diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Pattern.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Pattern.hs index db54e36..0e9f947 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Pattern.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Pattern.hs @@ -11,8 +11,6 @@ import GHC.Hs import qualified GHC.OldList as List import GHC.Types.Basic import Language.Haskell.Brittany.Internal.S3_ToBriDocTools -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.ToBriDoc.Expr -import Language.Haskell.Brittany.Internal.ToBriDoc.Type import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Components.BriDoc @@ -35,7 +33,9 @@ layoutPat lpat@(L _ pat) = docHandleComms lpat $ case pat of -- _ -> expr VarPat _ n -> fmap Seq.singleton $ docLit $ lrdrNameToText n -- abc -> expr - LitPat _ lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit + LitPat _ lit -> do + layouters <- mAsk + fmap Seq.singleton $ allocateNode $ layout_lit layouters lit -- 0 -> expr ParPat _ inner -> do -- (nestedpat) -> expr @@ -142,7 +142,7 @@ layoutPat lpat@(L _ pat) = docHandleComms lpat $ case pat of SigPat _ pat1 (HsPS _ ty1) -> do -- i :: Int -> expr patDocs <- layoutPat pat1 - tyDoc <- shareDoc $ layoutType ty1 + tyDoc <- shareDoc $ callLayouter layout_type ty1 case Seq.viewr patDocs of Seq.EmptyR -> error "cannot happen ljoiuxoasdcoviuasd" xR Seq.:> xN -> do @@ -173,13 +173,14 @@ layoutPat lpat@(L _ pat) = docHandleComms lpat $ case pat of -- -13 -> expr -- TODO92 we had `docWrapNode llit` below, but I don't think that is -- necessary/possible any longer.. - litDoc <- allocateNode $ overLitValBriDoc $ GHC.ol_val ol + layouters <- mAsk + litDoc <- allocateNode $ layout_overLit layouters $ GHC.ol_val ol negDoc <- docLit $ Text.pack "-" pure $ case mNegative of Just{} -> Seq.fromList [negDoc, litDoc] Nothing -> Seq.singleton litDoc ViewPat epAnn pat1 pat2 -> do - pat1Doc <- docHandleComms epAnn $ layoutExpr pat1 + pat1Doc <- docHandleComms epAnn $ callLayouter layout_expr pat1 let arrowLoc = obtainAnnPos epAnn AnnRarrow pat1DocC <- appSep $ pure pat1Doc pat2Docs <- layoutPat pat2 diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs index f7fe21f..c4d6d5a 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs @@ -9,9 +9,6 @@ import GHC (GenLocated(L)) import GHC.Hs import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.S3_ToBriDocTools -import Language.Haskell.Brittany.Internal.ToBriDoc.Decl -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.ToBriDoc.Expr -import Language.Haskell.Brittany.Internal.ToBriDoc.Pattern import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Components.BriDoc @@ -28,10 +25,11 @@ layoutStmt lstmt@(L _ stmt) = do -- at least the "|" of a monadcomprehension for _some_ reason -- is connected to the _body_ of the "result" stmt. So we need -- to docHandleListElemComms here.. - docHandleListElemComms layoutExpr body + docHandleListElemComms (callLayouter layout_expr) body BindStmt epAnn lPat expr -> docHandleComms epAnn $ do - patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat - expDoc <- shareDoc $ layoutExpr expr + patDoc <- fmap return + $ callLayouter layout_colsWrapPat =<< callLayouter layout_pat lPat + expDoc <- shareDoc $ callLayouter layout_expr expr docAlt [ docCols ColBindStmt @@ -51,7 +49,7 @@ layoutStmt lstmt@(L _ stmt) = do LetStmt epAnn binds -> docHandleComms epAnn $ do let isFree = indentPolicy == IndentPolicyFree let indentFourPlus = indentAmount >= 4 - layoutLocalBinds binds >>= \case + callLayouter layout_localBinds binds >>= \case Nothing -> docLit $ Text.pack "let" -- i just tested the above, and it is indeed allowed. heh. Just (_, []) -> docLit $ Text.pack "let" -- this probably never happens @@ -114,6 +112,6 @@ layoutStmt lstmt@(L _ stmt) = do (docLit (Text.pack "rec")) (docLines $ layoutStmt <$> stmts) BodyStmt NoExtField expr _ _ -> do - expDoc <- shareDoc $ layoutExpr expr + expDoc <- shareDoc $ callLayouter layout_expr expr docAddBaseY BrIndentRegular $ expDoc _ -> briDocByExactInlineOnly "some unknown statement" lstmt diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs-boot b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs-boot deleted file mode 100644 index 5e4694f..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs-boot +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.ToBriDoc.Stmt where - -import GHC.Hs -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Components.BriDoc - - - -layoutStmt :: GuardLStmt GhcPs -> ToBriDocM BriDocNumbered diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs index ea88739..83d14da 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs @@ -17,14 +17,13 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Components.BriDoc import Language.Haskell.Brittany.Internal.Utils (FirstLastView(..), splitFirstLast) -import Language.Haskell.Brittany.Internal.ToBriDoc.OpTree layoutSigType :: ToBriDoc HsSigType -- TODO92 we ignore an ann here layoutSigType (L _ (HsSig _ outerVarBind typ)) = case outerVarBind of - HsOuterImplicit _ -> layoutType typ + HsOuterImplicit _ -> callLayouter layout_type typ HsOuterExplicit _ bndrs -> do parts <- splitHsForallTypeFromBinders (map withoutSpecificity bndrs) typ joinSplitArrowType (hasAnyCommentsBelow typ) parts @@ -264,8 +263,9 @@ layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of (docLines $ lines ++ [wrapEnd end]) ] HsOpTy{} -> do - treeAndHasComms <- gatherOpTreeT False False id Nothing Nothing [] ltype - processOpTree treeAndHasComms + layouters <- mAsk + treeAndHasComms <- layout_gatherOpTreeT layouters False False id Nothing Nothing [] ltype + layout_opTree layouters treeAndHasComms -- HsOpTy typ1 opName typ2 -> do -- -- TODO: these need some proper fixing. precedences don't add up. -- -- maybe the parser just returns some trivial right recursion diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs-boot b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs-boot deleted file mode 100644 index 3d1d004..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.ToBriDoc.Type where - -import GHC.Hs - -import Language.Haskell.Brittany.Internal.Types - -layoutType :: ToBriDoc HsType diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs index 7ee6ecd..e7a7bc1 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Types.hs @@ -13,6 +13,7 @@ import qualified Data.Data import qualified Data.Kind as Kind import qualified GHC.OldList as List import qualified Data.Text.Lazy.Builder as Text.Builder +import qualified GHC import GHC ( Anno , DeltaPos ( DifferentLine @@ -152,10 +153,125 @@ ppmMoveToExactLoc = \case type ToBriDocM = MultiRWSS.MultiRWS - '[Config, TraceFunc] -- reader + '[Config, TraceFunc, Layouters] -- reader '[[BrittanyError], Seq String] -- writer '[NodeAllocIndex, CommentCounter] -- state +data OpTree + = OpUnknown Bool -- Z paren? + (Maybe GHC.RealSrcLoc) -- paren open loc + (Maybe GHC.RealSrcLoc) -- paren close loc + OpTree -- left operand + [(BriDocNumbered, BriDocNumbered)] -- list of (next operand, symbol) + | OpKnown Bool -- with paren? + (Maybe GHC.RealSrcLoc) -- paren open loc + (Maybe GHC.RealSrcLoc) -- paren close loc + GHC.Fixity -- only Just after (successful!) lookup phase + OpTree + [(BriDocNumbered, OpTree)] + | OpLeaf BriDocNumbered + +data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted + +data Layouters = Layouters + { layout_expr :: ToBriDoc GHC.HsExpr + , layout_lit :: GHC.HsLit GhcPs -> BriDocWrapped + , layout_overLit :: GHC.OverLitVal -> BriDocWrapped + , layout_type :: ToBriDoc GHC.HsType + , layout_sigType :: ToBriDoc GHC.HsSigType + , layout_stmt :: GHC.GuardLStmt GhcPs -> ToBriDocM BriDocNumbered + , layout_gatherOpTreeE + :: Bool + -> Bool + -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) + -> Maybe GHC.RealSrcLoc + -> Maybe GHC.RealSrcLoc + -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)] + -> GHC.LHsExpr GhcPs + -> ToBriDocM (OpTree, Bool) + , layout_gatherOpTreeT + :: Bool + -> Bool + -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) + -> Maybe GHC.RealSrcLoc + -> Maybe GHC.RealSrcLoc + -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)] + -> GHC.LHsType GhcPs + -> ToBriDocM (OpTree, Bool) + , layout_opTree :: (OpTree, Bool) -> ToBriDocM BriDocNumbered + , layout_grhs + :: GHC.LGRHS GhcPs (GHC.LHsExpr GhcPs) + -> ToBriDocM + ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered + , [BriDocNumbered] + , BriDocNumbered + ) + , layout_pat :: GHC.LPat GhcPs -> ToBriDocM (Seq BriDocNumbered) + , layout_colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered + , layout_patternBind + :: Maybe Text + -> BriDocNumbered + -> GHC.LMatch GhcPs (GHC.LHsExpr GhcPs) + -> ToBriDocM BriDocNumbered + , layout_patternBindFinal + :: Maybe Text + -> BriDocNumbered + -> Maybe BriDocNumbered + -> Either (GHC.LHsExpr GhcPs) [GHC.LGRHS GhcPs (GHC.LHsExpr GhcPs)] + -> ( Maybe + ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered + , [BriDocNumbered] + ) + ) + -> Bool + -> ToBriDocM BriDocNumbered + , layout_localBinds + :: GHC.HsLocalBindsLR GhcPs GhcPs + -> ToBriDocM + ( Maybe + ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered + , [BriDocNumbered] + ) + ) + , layout_dataDecl + :: GHC.LTyClDecl GhcPs + -> GHC.EpAnn [GHC.AddEpAnn] + -> GHC.LIdP GhcPs + -> GHC.LHsQTyVars GhcPs + -> [GHC.LHsTypeArg GhcPs] + -> GHC.HsDataDefn GhcPs + -> ToBriDocM BriDocNumbered + , layout_tyVarBndrs + :: [GHC.LHsTyVarBndr () GhcPs] + -> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))] + , layout_tyVarBndrsSingleline + :: [(Text, Maybe (ToBriDocM BriDocNumbered))] -> [ToBriDocM BriDocNumbered] + , layout_hsTyPats + :: [GHC.LHsTypeArg GhcPs] -> [ToBriDocM BriDocNumbered] + , layout_LLIEs + :: HasCallStack + => Bool + -> SortItemsFlag + -> GHC.LocatedL [GHC.LIE GhcPs] + -> ToBriDocM BriDocNumbered + , layout_annAndSepLLIEs + :: forall a + . (Data.Data.Data a, HasCallStack) + => SortItemsFlag + -> a + -> [GHC.LIE GhcPs] + -> ToBriDocM [ToBriDocM BriDocNumbered] + } + +callLayouter + :: (Layouters -> a -> ToBriDocM r) + -> a + -> ToBriDocM r +callLayouter lens x = do + layouters <- mAsk + lens layouters x + + type ToBriDoc (sym :: Kind.Type -> Kind.Type) = XRec GhcPs (sym GhcPs) -> ToBriDocM BriDocNumbered type ToBriDoc' sym = XRec GhcPs (sym GhcPs) -> ToBriDocM BriDocNumbered type ToBriDocC sym c = XRec GhcPs (sym GhcPs) -> ToBriDocM c @@ -168,8 +284,8 @@ newtype CommentCounter = CommentCounter { unCommentCounter :: Int } -- Why does this live in types? As long as it does, you _have_ -- to remember to call `docFlushRemaining` in combination with this! -briDocMToPPM :: ToBriDocM a -> PPMLocal (a, Int) -briDocMToPPM m = do +briDocMToPPM :: Layouters -> ToBriDocM a -> PPMLocal (a, Int) +briDocMToPPM layouters m = do readers <- MultiRWSS.mGetRawR initCount <- MultiRWSS.mGet @CommentCounter let (((x, errs), debugs), commentCount) = @@ -177,6 +293,7 @@ briDocMToPPM m = do $ MultiRWSS.runMultiRWSTNil $ MultiRWSS.withMultiStateAS initCount $ MultiRWSS.withMultiStateA (NodeAllocIndex 1) + $ MultiRWSS.withMultiReader layouters $ MultiRWSS.withMultiReaders readers $ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterAW