{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} module Language.Haskell.Brittany.Internal.ToBriDoc.Decl where import qualified Data.Data import qualified Data.Foldable import qualified Data.Maybe import qualified Data.Text as Text import GHC (GenLocated(L), LexicalFixity(Prefix, Infix), SrcSpan) import GHC.Data.Bag (bagToList, emptyBag) import qualified GHC.Data.FastString as FastString import GHC.Hs import qualified GHC.OldList as List import GHC.Types.Basic (Activation(..), InlinePragma(..), InlineSpec(..), RuleMatchInfo(..)) import GHC.Types.SrcLoc (Located, getLoc, unLoc) 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 import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint import Language.Haskell.Brittany.Internal.Components.BriDoc layoutDecl :: ToBriDoc HsDecl layoutDecl d@(L loc decl) = case decl of SigD _ sig -> layoutSig d sig ValD _ bind -> layoutBind (L loc bind) >>= \case Left ns -> docLines $ return <$> ns Right n -> return n TyClD _ tycl -> layoutTyCl (L loc tycl) InstD NoExtField (TyFamInstD NoExtField tfid) -> layoutTyFamInstDecl False d tfid InstD NoExtField (ClsInstD NoExtField inst) -> layoutClsInst d inst _ -> briDocByExactNoComment d -------------------------------------------------------------------------------- -- Sig -------------------------------------------------------------------------------- layoutSig :: (Data.Data.Data ast, ExactPrint.ExactPrint ast) => (LocatedA ast) -> ToBriDocP Sig layoutSig fallback sig = case sig of TypeSig epAnn names (HsWC _ sigTy) -> layoutNamesAndType epAnn Nothing names sigTy InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> do nameStr <- lrdrNameToTextAnn name specStr <- specStringCompat spec let phaseStr = case phaseAct of NeverActive -> "" -- not [] - for NOINLINE NeverActive is -- in fact the default AlwaysActive -> "" ActiveBefore _ i -> "[~" ++ show i ++ "] " ActiveAfter _ i -> "[" ++ show i ++ "] " FinalActive -> error "brittany internal error: FinalActive" let conlikeStr = case conlike of FunLike -> "" ConLike -> "CONLIKE " docLit $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) <> nameStr <> Text.pack " #-}" ClassOpSig epAnn False names sigTy -> layoutNamesAndType epAnn Nothing names sigTy -- TODO92 we ignore an ann here PatSynSig epAnn names sigTy -> -- TODO92 we ignore an ann here layoutNamesAndType epAnn (Just "pattern") names sigTy _ -> briDocByExactNoComment fallback -- TODO where layoutNamesAndType :: EpAnn AnnSig -> Maybe String -> [LIdP GhcPs] -> LHsSigType GhcPs -> ToBriDocM BriDocNumbered layoutNamesAndType epAnn mKeyword names sigTy = docHandleComms epAnn $ do -- TODO92 epAnn might contain interesting bits (the key loc?) let keyDoc = case mKeyword of Just key -> [appSep . docLit $ Text.pack key] Nothing -> [] let (AnnSig addEpAnn _) = anns epAnn let posColon = obtainAnnPos addEpAnn AnnDcolon nameStrs <- names `forM` lrdrNameToTextAnn let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs typeDoc <- shareDoc $ layoutSigType sigTy let hasComments = hasAnyCommentsBelow fallback shouldBeHanging <- mAsk <&> _conf_layout .> _lconfig_hangingTypeSignature .> confUnpack if shouldBeHanging then docSeq $ [ appSep $ docSeq $ keyDoc <> [docLit nameStr] , docSetBaseY $ docLines [ docCols ColTyOpPrefix [ docHandleComms posColon $ docLit $ Text.pack ":: " , docAddBaseY (BrIndentSpecial 3) $ typeDoc ] ] ] else layoutLhsAndType hasComments (appSep . docSeq $ keyDoc <> [docLit nameStr]) (docHandleComms posColon $ docLit $ Text.pack "::") 2 (typeDoc) specStringCompat :: MonadMultiWriter [BrittanyError] m => InlineSpec -> m String specStringCompat = \case -- TODO92 better error for this? NoUserInlinePrag -> error "NoUserInlinePrag" Inline -> pure "INLINE " Inlinable -> pure "INLINABLE " NoInline -> pure "NOINLINE " -- layoutGuardLStmt :: ToBriDoc' (StmtLR rdL rdR) -- ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) -- layoutGuardLStmt lgstmt@(L _ stmtLR) = case stmtLR of -- TODO92 we had an `docWrapNode lgstmt` here -- -- but it seems we can't have comments in 92? -- BodyStmt _ body _ _ -> briDocByExactNoComment body -- TODO92 layoutExpr body -- BindStmt _ lPat expr -> do -- patDoc <- docSharedWrapper briDocByExactNoComment lPat -- TODO92 layoutPat -- expDoc <- docSharedWrapper briDocByExactNoComment expr -- TODO92 layoutExpr -- docCols -- ColBindStmt -- [ appSep $ patDoc -- TODO92 colsWrapPat =<< patDoc -- , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] -- ] -- _ -> unknownNodeError "" lgstmt -- TODO -------------------------------------------------------------------------------- -- HsBind -------------------------------------------------------------------------------- layoutBind :: ToBriDocC (HsBindLR GhcPs) (Either [BriDocNumbered] BriDocNumbered) layoutBind lbind@(L _ bind) = case bind of FunBind NoExtField fId (MG NoExtField _lmatches@(L _ matches) _) [] -> do idStr <- lrdrNameToTextAnn fId binderDoc <- docLit $ Text.pack "=" funcPatDocs <- docHandleComms lbind $ 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 -- let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey? binderDoc <- docLit $ Text.pack "=" let hasComments = hasAnyCommentsBelow lbind fmap Right $ docHandleComms lbind $ layoutPatternBindFinal Nothing binderDoc (Just patDocs) (Right grhss) mWhereDocs hasComments PatSynBind _ (PSB _ patID lpat rpat dir) -> do fmap Right $ docHandleComms lbind $ layoutPatSynBind patID lpat dir rpat _ -> Right <$> unknownNodeError "" lbind layoutIPBind :: ToBriDoc IPBind layoutIPBind lipbind@(L _ bind) = case bind of IPBind _ (Right _) _ -> error "brittany internal error: IPBind Right" IPBind _ (Left (L _ (HsIPName name))) expr -> do ipName <- docLit $ Text.pack $ '?' : FastString.unpackFS name binderDoc <- docLit $ Text.pack "=" let hasComments = hasAnyCommentsBelow lipbind layoutPatternBindFinal Nothing binderDoc (Just ipName) (Left expr) Nothing hasComments data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) | BagSig (LSig GhcPs) bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan bindOrSigtoSrcSpan (BagBind (L (SrcSpanAnn _ l) _)) = l bindOrSigtoSrcSpan (BagSig (L (SrcSpanAnn _ l) _)) = l layoutLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> ToBriDocM ( Maybe ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered , [BriDocNumbered] ) ) layoutLocalBinds binds = case binds of -- HsValBinds (ValBindsIn lhsBindsLR []) -> -- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering -- x@(HsValBinds (ValBindsIn{})) -> -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x HsValBinds epAnn (ValBinds _ bindlrs sigs) -> do let locWhere = obtainAnnPos epAnn AnnWhere let unordered = [ BagBind b | b <- Data.Foldable.toList bindlrs ] ++ [ BagSig s | s <- sigs ] ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered ds <- docHandleComms epAnn $ join <$> ordered `forM` \case BagBind b -> either id return <$> layoutBind b BagSig s@(L _ sig) -> do doc <- layoutSig s sig pure [doc] pure $ Just (docHandleComms locWhere, ds) -- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" HsIPBinds epAnn (IPBinds _ bb) -> do ds <- docHandleComms epAnn $ mapM layoutIPBind bb pure $ Just (id, ds) -- TODO92 do we need to replace id? EmptyLocalBinds NoExtField -> return $ Nothing layoutGrhs :: LGRHS GhcPs (LHsExpr GhcPs) -> ToBriDocM ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered , [BriDocNumbered] , BriDocNumbered ) 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 return (docHandleComms epAnn, guardDocs, bodyDoc) layoutPatternBind :: Maybe Text -> BriDocNumbered -> LMatch GhcPs (LHsExpr GhcPs) -> 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 let isInfix = isInfixMatch match let matchEndLoc = case GHC.locA $ GHC.getLoc lmatch of GHC.RealSrcSpan s _ -> Just $ GHC.realSrcSpanEnd s GHC.UnhelpfulSpan{} -> Nothing mIdDoc <- case matchCtx of FunRhs matchId _ _ -> fmap Just $ do t <- lrdrNameToTextAnn matchId let t' = fixPatternBindIdentifier match t docLit t' _ -> pure Nothing patDoc <- docHandleComms lmatch $ case (mIdDoc, patDocs) of (Just idDoc, p1 : p2 : pr) | isInfix -> if null pr then docCols ColPatternsFuncInfix [ appSep $ docForceSingleline p1 , appSep $ pure idDoc , docForceSingleline p2 ] else docCols ColPatternsFuncInfix ([ docCols ColPatterns [ docParenL , appSep $ docForceSingleline p1 , appSep $ pure idDoc , docForceSingleline p2 , appSep $ docParenR ] ] ++ (spacifyDocs $ docForceSingleline <$> pr) ) (Just idDoc, []) -> pure idDoc (Just idDoc, ps) -> docCols ColPatternsFuncPrefix $ appSep (pure idDoc) : (spacifyDocs $ docForceSingleline <$> ps) (Nothing, ps) -> docCols ColPatterns $ (List.intersperse docSeparator $ docForceSingleline <$> ps) mWhereDocs <- layoutLocalBinds whereBinds -- let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch) let alignmentToken = if null pats then Nothing else funId let hasComments = hasAnyCommentsBelow lmatch docHandleComms lmatch $ docHandleComms epAnn $ docFlushCommsPost True matchEndLoc $ layoutPatternBindFinal alignmentToken binderDoc (Just patDoc) (Right grhss) mWhereDocs hasComments fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text fixPatternBindIdentifier match idStr = go $ m_ctxt match where go = \case (FunRhs _ _ SrcLazy) -> Text.cons '~' idStr (FunRhs _ _ SrcStrict) -> Text.cons '!' idStr (FunRhs _ _ NoSrcStrict) -> idStr (StmtCtxt ctx1) -> goInner ctx1 _ -> idStr -- I have really no idea if this path ever occurs, but better safe than -- risking another "drop bangpatterns" bugs. goInner = \case (PatGuard ctx1) -> go ctx1 (ParStmtCtxt ctx1) -> goInner ctx1 (TransStmtCtxt ctx1) -> goInner ctx1 _ -> idStr layoutPatternBindFinal :: Maybe Text -> BriDocNumbered -> Maybe BriDocNumbered -> Either (LHsExpr GhcPs) [LGRHS GhcPs (LHsExpr GhcPs)] -> ( Maybe ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered , [BriDocNumbered] ) ) -> Bool -> ToBriDocM BriDocNumbered layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauses mWhereDocs hasComments = do let patPartInline = case mPatDoc of Nothing -> [] Just patDoc -> [appSep $ docForceSingleline $ return patDoc] patPartParWrap = case mPatDoc of Nothing -> id Just patDoc -> docPar (return patDoc) whereIndent <- do shouldSpecial <- mAsk <&> _conf_layout .> _lconfig_indentWhereSpecial .> confUnpack regularIndentAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack pure $ if shouldSpecial then BrIndentSpecial (max 1 (regularIndentAmount `div` 2)) else BrIndentRegular -- TODO: apart from this, there probably are more nodes below which could -- be shared between alternatives. wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of Nothing -> return $ [] Just (wrapWhere, [w]) -> pure . pure <$> docAlt [ docEnsureIndent BrIndentRegular $ docSeq [ wrapWhere $ docLit $ Text.pack "where" , docSeparator , docForceSingleline $ return w ] , -- docMoveToKWDP annKeyWhere AnnWhere False -- TODO92 docEnsureIndent whereIndent $ docLines [ docLit $ Text.pack "where" , docEnsureIndent whereIndent $ docSetIndentLevel $ docNonBottomSpacing $ return w ] ] Just (wrapWhere, ws) -> fmap (pure . pure) -- $ docMoveToKWDP annKeyWhere AnnWhere False -- TODO92 $ docEnsureIndent whereIndent $ docLines [ wrapWhere $ docLit $ Text.pack "where" , docEnsureIndent whereIndent $ docSetIndentLevel $ docNonBottomSpacing $ docLines $ return <$> ws ] let singleLineGuardsDoc guards = appSep $ case guards of [] -> docEmpty [g] -> docSeq [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] gs -> docSeq $ [appSep $ docLit $ Text.pack "|"] ++ (List.intersperse docCommaSep (docForceSingleline . return <$> gs) ) wherePart = case mWhereDocs of Nothing -> Just docEmpty Just (wrapWhere, [w]) -> Just $ docSeq [ docSeparator , wrapWhere $ appSep $ docLit $ Text.pack "where" , docSetIndentLevel $ docForceSingleline $ return w ] _ -> Nothing indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack clauseDocs <- case clauses of Left expr -> do e <- layoutExpr expr pure [(id, [], e)] Right grhss -> layoutGrhs `mapM` grhss runFilteredAlternative $ do case clauseDocs of [(wrapClause, guards, body)] -> do let guardPart = wrapClause $ singleLineGuardsDoc guards forM_ wherePart $ \wherePart' -> -- one-line solution addAlternativeCond (not hasComments) $ docCols (ColBindingLine alignmentToken) [ docSeq (patPartInline ++ [guardPart]) , docSeq [ appSep $ return binderDoc , docForceSingleline $ return body , wherePart' ] ] -- one-line solution + where in next line(s) addAlternativeCond (Data.Maybe.isJust mWhereDocs) $ docLines $ [ docCols (ColBindingLine alignmentToken) [ docSeq (patPartInline ++ [guardPart]) , docSeq [ appSep $ return binderDoc , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body ] ] ] ++ wherePartMultiLine -- two-line solution + where in next line(s) addAlternative $ docLines $ [ docForceSingleline $ docSeq (patPartInline ++ [guardPart, return binderDoc]) , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body ] ++ wherePartMultiLine -- pattern and exactly one clause in single line, body as par; -- where in following lines addAlternative $ docLines $ [ docCols (ColBindingLine alignmentToken) [ docSeq (patPartInline ++ [guardPart]) , docSeq [ appSep $ return binderDoc , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body ] ] ] -- , lineMod $ docAlt -- [ docSetBaseY $ return body -- , docAddBaseY BrIndentRegular $ return body -- ] ++ wherePartMultiLine -- pattern and exactly one clause in single line, body in new line. addAlternative $ docLines $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) , docNonBottomSpacing $ docEnsureIndent BrIndentRegular $ docAddBaseY BrIndentRegular $ return body ] ++ wherePartMultiLine _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1` case mPatDoc of Nothing -> return () Just patDoc -> -- multiple clauses added in-paragraph, each in a single line -- example: foo | bar = baz -- | lll = asd addAlternativeCond (indentPolicy == IndentPolicyFree) $ docLines $ [ docSeq [ appSep $ docForceSingleline $ return patDoc , docSetBaseY $ docLines $ clauseDocs <&> \(wrapClause, guardDocs, bodyDoc) -> wrapClause $ do -- TODO92 let guardPart = singleLineGuardsDoc guardDocs -- the docForceSingleline might seems superflous, but it -- helps the alternative resolving impl. docForceSingleline $ docCols ColGuardedBody [ guardPart , docSeq [ appSep $ return binderDoc , docForceSingleline $ return bodyDoc -- i am not sure if there is a benefit to using -- docForceParSpacing additionally here: -- , docAddBaseY BrIndentRegular $ return bodyDoc ] ] ] ] ++ wherePartMultiLine -- multiple clauses, each in a separate, single line addAlternative $ docLines $ [ docAddBaseY BrIndentRegular $ patPartParWrap $ docLines $ map docSetBaseY $ clauseDocs <&> \(wrapClause, guardDocs, bodyDoc) -> wrapClause $ do -- TODO92 let guardPart = singleLineGuardsDoc guardDocs -- the docForceSingleline might seems superflous, but it -- helps the alternative resolving impl. docForceSingleline $ docCols ColGuardedBody [ guardPart , docSeq [ appSep $ return binderDoc , docForceSingleline $ return bodyDoc -- i am not sure if there is a benefit to using -- docForceParSpacing additionally here: -- , docAddBaseY BrIndentRegular $ return bodyDoc ] ] ] ++ wherePartMultiLine -- multiple clauses, each with the guard(s) in a single line, body -- as a paragraph addAlternativeCond (not hasComments) $ docLines $ [ docAddBaseY BrIndentRegular $ patPartParWrap $ docLines $ map docSetBaseY $ clauseDocs <&> \(wrapClause, guardDocs, bodyDoc) -> -- TODO92 wrapClause $ docSeq $ (case guardDocs of [] -> [] [g] -> [ docForceSingleline $ docSeq [appSep $ docLit $ Text.pack "|", return g] ] gs -> [ docForceSingleline $ docSeq $ [appSep $ docLit $ Text.pack "|"] ++ List.intersperse docCommaSep (return <$> gs) ] ) ++ [ docSeparator , docCols ColOpPrefix [ appSep $ return binderDoc , docAddBaseY BrIndentRegular $ docForceParSpacing $ return bodyDoc ] ] ] ++ wherePartMultiLine -- multiple clauses, each with the guard(s) in a single line, body -- in a new line as a paragraph addAlternative $ docLines $ [ docAddBaseY BrIndentRegular $ patPartParWrap $ docLines $ map docSetBaseY $ clauseDocs >>= \(wrapClause, guardDocs, bodyDoc) -> -- TODO92 (case guardDocs of [] -> [wrapClause docEmpty] [g] -> [ wrapClause $ docForceSingleline $ docSeq [appSep $ docLit $ Text.pack "|", return g] ] gs -> [ wrapClause $ docForceSingleline $ docSeq $ [appSep $ docLit $ Text.pack "|"] ++ List.intersperse docCommaSep (return <$> gs) ] ) ++ [ docCols ColOpPrefix [ appSep $ return binderDoc , docAddBaseY BrIndentRegular $ docForceParSpacing $ return bodyDoc ] ] ] ++ wherePartMultiLine -- conservative approach: everything starts on the left. addAlternative $ docLines $ [ docAddBaseY BrIndentRegular $ patPartParWrap $ docLines $ map docSetBaseY $ clauseDocs >>= \(wrapClause, guardDocs, bodyDoc) -> -- TODO92 (case guardDocs of [] -> [wrapClause docEmpty] [g] -> [ wrapClause $ docSeq [appSep $ docLit $ Text.pack "|", return g] ] (g1 : gr) -> ( (wrapClause $ docSeq [appSep $ docLit $ Text.pack "|", return g1]) : (gr <&> \g -> docSeq [appSep $ docLit $ Text.pack ",", return g] ) ) ) ++ [ docCols ColOpPrefix [ appSep $ return binderDoc , docAddBaseY BrIndentRegular $ return bodyDoc ] ] ] ++ wherePartMultiLine -- | Layout a pattern synonym binding layoutPatSynBind :: LIdP GhcPs -> HsPatSynDetails GhcPs -> HsPatSynDir GhcPs -> LPat GhcPs -> ToBriDocM BriDocNumbered layoutPatSynBind name patSynDetails patDir rpat = do let patDoc = docLit $ Text.pack "pattern" binderDoc = case patDir of ImplicitBidirectional -> docLit $ Text.pack "=" _ -> docLit $ Text.pack "<-" body = colsWrapPat =<< layoutPat rpat whereDoc = docLit $ Text.pack "where" mWhereDocs <- layoutPatSynWhere patDir headDoc <- fmap pure $ docSeq $ [ patDoc , docSeparator , layoutLPatSyn name patSynDetails , docSeparator , binderDoc ] runFilteredAlternative $ do addAlternative $ -- pattern .. where -- .. -- .. docAddBaseY BrIndentRegular $ docSeq ([headDoc, docSeparator, body] ++ case mWhereDocs of Just ds -> [docSeparator, docPar whereDoc (docLines ds)] Nothing -> [] ) addAlternative $ -- pattern .. = -- .. -- pattern .. <- -- .. where -- .. -- .. docAddBaseY BrIndentRegular $ docPar headDoc (case mWhereDocs of Nothing -> body Just ds -> docLines ([docSeq [body, docSeparator, whereDoc]] ++ ds) ) -- | Helper method for the left hand side of a pattern synonym layoutLPatSyn :: LIdP GhcPs -> HsPatSynDetails GhcPs -> ToBriDocM BriDocNumbered layoutLPatSyn name (PrefixCon _ vars) = do docName <- lrdrNameToTextAnn name names <- mapM lrdrNameToTextAnn vars docSeq . fmap appSep $ docLit docName : (docLit <$> names) layoutLPatSyn name (InfixCon left right) = do leftDoc <- lrdrNameToTextAnn left docName <- lrdrNameToTextAnn name rightDoc <- lrdrNameToTextAnn right docSeq . fmap (appSep . docLit) $ [leftDoc, docName, rightDoc] layoutLPatSyn name (RecCon recArgs) = do docName <- lrdrNameToTextAnn name args <- mapM (lrdrNameToTextAnn . rdrNameFieldOcc . recordPatSynField) recArgs docSeq . fmap docLit $ [docName, Text.pack " { "] <> intersperse (Text.pack ", ") args <> [Text.pack " }"] -- | Helper method to get the where clause from of explicitly bidirectional -- pattern synonyms layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) layoutPatSynWhere hs = case hs of ExplicitBidirectional (MG NoExtField lbinds@(L _ binds) _) -> do binderDoc <- docLit $ Text.pack "=" bindDocs <- mapM (shareDoc . layoutPatternBind Nothing binderDoc) binds pure $ Just $ docHandleComms lbinds bindDocs _ -> pure Nothing -------------------------------------------------------------------------------- -- TyClDecl -------------------------------------------------------------------------------- layoutTyCl :: ToBriDoc TyClDecl layoutTyCl ltycl@(L _loc tycl) = case tycl of SynDecl epAnn name vars fixity typ -> do let isInfix = case fixity of Prefix -> False Infix -> True let posEqual = obtainAnnPos epAnn AnnEqual let posOpen = obtainAnnPos epAnn AnnOpenP -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP -- let parenWrapper = if hasTrailingParen -- then appSep . docWrapNodeRest ltycl -- else id docHandleComms ltycl $ docHandleComms epAnn $ do nameStr <- lrdrNameToTextAnn name let lhs = appSep $ if isInfix then do let (a, b, rest) = case hsq_explicit vars of (v1 : v2 : vR) -> (v1, v2, vR) _ -> error "unexpected vars, expected at least 2" -- This isn't quite right, but does give syntactically valid results let needsParens = not (null rest) || Data.Maybe.isJust posOpen docSeq $ [docLit $ Text.pack "type", docSeparator] ++ [ docParenL | needsParens ] ++ [ layoutTyVarBndr False a , docSeparator , docLit nameStr , docSeparator , layoutTyVarBndr False b ] ++ [ docParenR | needsParens ] ++ fmap (layoutTyVarBndr True) rest else docSeq $ [ docLit $ Text.pack "type" , docSeparator , docHandleComms name $ docLit nameStr ] ++ fmap (layoutTyVarBndr True) (hsq_explicit vars) sharedLhs <- shareDoc $ id lhs typeDoc <- shareDoc $ layoutType 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 _ -> briDocByExactNoComment ltycl layoutTyVarBndr :: Bool -> ToBriDoc (HsTyVarBndr ()) layoutTyVarBndr needsSep (L _ bndr) = case bndr of UserTyVar _ _ name -> do nameStr <- lrdrNameToTextAnn name docSeq $ [ docSeparator | needsSep ] ++ [docLit nameStr] KindedTyVar _ _ name kind -> do nameStr <- lrdrNameToTextAnn name docSeq $ [ docSeparator | needsSep ] ++ [ docLit $ Text.pack "(" , appSep $ docLit nameStr , appSep . docLit $ Text.pack "::" , docForceSingleline $ layoutType kind , docLit $ Text.pack ")" ] -------------------------------------------------------------------------------- -- TyFamInstDecl -------------------------------------------------------------------------------- layoutTyFamInstDecl :: Data.Data.Data a => Bool -> LocatedA a -> TyFamInstDecl GhcPs -> ToBriDocM BriDocNumbered layoutTyFamInstDecl inClass outerNode tfid = do let posType = obtainAnnPos (tfid_xtn tfid) AnnType FamEqn epAnn name bndrsMay pats _fixity typ = tfid_eqn tfid posEqual = obtainAnnPos epAnn AnnEqual -- bndrsMay isJust e.g. with -- type instance forall a . MyType (Maybe a) = Either () a nameStr <- lrdrNameToTextAnn name -- TODO92 needsParens <- hasAnnKeyword outerNode AnnOpenP let needsParens = False let instanceDoc = docHandleComms posType $ if inClass then docLit $ Text.pack "type" else docSeq [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"] makeForallDoc :: [LHsTyVarBndr () GhcPs] -> ToBriDocM BriDocNumbered makeForallDoc bndrs = do bndrDocs <- layoutTyVarBndrs bndrs docSeq ([docLit (Text.pack "forall")] ++ processTyVarBndrsSingleline bndrDocs ) lhs = docHandleComms epAnn $ docSeq $ [appSep instanceDoc] ++ [ makeForallDoc foralls | (HsOuterExplicit _ foralls) <- [bndrsMay] ] ++ [ docParenL | needsParens ] ++ [appSep $ docHandleComms name $ docLit nameStr] ++ intersperse docSeparator (layoutHsTyPats pats) ++ [ docParenR | needsParens ] -- TODO92 hasComments <- -- (||) -- <$> hasAnyRegularCommentsConnected outerNode -- <*> hasAnyRegularCommentsRest innerNode let hasComments = hasAnyCommentsConnected outerNode typeDoc <- shareDoc $ layoutType typ layoutLhsAndType hasComments lhs (docHandleComms posEqual $ docLit $ Text.pack "=") 1 typeDoc -------------------------------------------------------------------------------- -- ClsInstDecl -------------------------------------------------------------------------------- -- | Layout an @instance@ declaration -- -- Layout signatures and bindings using the corresponding layouters from the -- top-level. Layout the instance head, type family instances, and data family -- instances using ExactPrint. layoutClsInst :: LHsDecl GhcPs -> ClsInstDecl GhcPs -> ToBriDocM BriDocNumbered layoutClsInst (L declLoc _) cid = do -- _ x docLines [ layoutInstanceHead , docEnsureIndent BrIndentRegular $ docSetIndentLevel $ docSortedLines $ fmap layoutAndLocateSig (cid_sigs cid) ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) ++ fmap layoutAndLocateDataFamInsts (cid_datafam_insts cid) ] where layoutInstanceHead :: ToBriDocM BriDocNumbered layoutInstanceHead = case cid_ext cid of (EpAnn annAnchor addEpAnns (EpaComments comms), sortKey) -> do let posWhere = obtainAnnPos addEpAnns AnnWhere let (commsBefore, commsAfter) = partition (\(L anch _) -> (Just $ GHC.realSrcSpanStart $ anchor anch) < posWhere) comms docHandleComms (reverse commsAfter) $ briDocByExactNoComment $ L declLoc $ InstD NoExtField $ ClsInstD NoExtField $ (removeChildren cid) { cid_ext = (EpAnn annAnchor addEpAnns (EpaComments commsBefore), sortKey) } _ -> briDocByExactNoComment $ L declLoc $ InstD NoExtField $ ClsInstD NoExtField $ removeChildren cid removeChildren :: ClsInstDecl GhcPs -> ClsInstDecl GhcPs removeChildren c = c { cid_binds = emptyBag , cid_sigs = [] , cid_tyfam_insts = [] , cid_datafam_insts = [] } -- | Like 'docLines', but sorts the lines based on location docSortedLines :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered docSortedLines l = allocateNode . BDLines . fmap unLoc . List.sortOn (ExactPrint.rs . getLoc) =<< sequence l layoutAndLocateSig :: ToBriDocC Sig (Located BriDocNumbered) layoutAndLocateSig lsig@(L (SrcSpanAnn _ loc) sig) = L loc <$> layoutSig lsig sig layoutAndLocateBind :: LHsBind GhcPs -> ToBriDocM (Located BriDocNumbered) layoutAndLocateBind lbind@(L (SrcSpanAnn _ loc) _) = L loc <$> (joinBinds =<< layoutBind lbind) joinBinds :: Either [BriDocNumbered] BriDocNumbered -> ToBriDocM BriDocNumbered joinBinds = \case Left ns -> docLines $ return <$> ns Right n -> return n layoutAndLocateTyFamInsts :: ToBriDocC TyFamInstDecl (Located BriDocNumbered) layoutAndLocateTyFamInsts ltfid@(L (SrcSpanAnn _ loc) tfid) = L loc <$> layoutTyFamInstDecl True ltfid tfid layoutAndLocateDataFamInsts :: ToBriDocC DataFamInstDecl (Located BriDocNumbered) layoutAndLocateDataFamInsts ldfid@(L (SrcSpanAnn _ loc) _) = L loc <$> layoutDataFamInstDecl ldfid -- | Send to ExactPrint then remove unecessary whitespace layoutDataFamInstDecl :: ToBriDoc DataFamInstDecl layoutDataFamInstDecl ldfid@(L _ (DataFamInstDecl famEqn)) = docHandleComms ldfid $ case famEqn of FamEqn epAnn tycon bndrs pats Prefix rhs -> do layoutDataDecl (error "Unsupported form of DataFamInstDecl") epAnn tycon (case bndrs of HsOuterImplicit NoExtField -> HsQTvs NoExtField [] HsOuterExplicit _ innerBndrs -> HsQTvs NoExtField $ innerBndrs ) pats rhs _ -> error "Unsupported DataFamInstDecl" -- case rhs of -- HsDataDefn NoExtField NewType Nothing Nothing Nothing [lcons] [] -> -- let L _ cons = lcons -- case cons of -- ConDeclH98 _ext cName False _qvars ctxMay details _conDoc -> do -- -- (Just (L _ [])) = ctxMay -- nameStr <- lrdrNameToTextAnn tycon -- consNameStr <- lrdrNameToTextAnn cName -- tyVarLine <- return <$> createBndrDoc bndrs -- let -- isInfix = case fixity of -- Prefix -> False -- Infix -> True -- _ x -- docHandleComms epAnn -- $ docSeq -- $ [appSep $ docLitS "newtype", appSep $ docLit nameStr] -- ++ [ makeForallDoc foralls | (HsOuterExplicit _ foralls) <- [bndrs] ] -- ++ [ _ pats ] -- fmap stripWhitespace <$> undefined -- TODO92 !!! briDocByExactNoComment ldfid -------------------------------------------------------------------------------- -- Common Helpers -------------------------------------------------------------------------------- layoutLhsAndType :: Bool -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -> Int -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered layoutLhsAndType hasComments lhs sep sepLen typeDoc = do runFilteredAlternative $ do -- (separators probably are "=" or "::") -- lhs = type -- lhs :: type addAlternativeCond (not hasComments) $ docSeq [lhs, docSeparator, sep, docSeparator, docForceSingleline typeDoc] -- lhs -- :: typeA -- -> typeB -- lhs -- = typeA -- -> typeB addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols ColTyOpPrefix [ appSep sep , docAddBaseY (BrIndentSpecial (sepLen + 1)) typeDoc ]