{-# 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.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 $ callLayouter layout_sigType 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 <- 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 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) (id, 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 ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered , 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 <- join <$> ordered `forM` \case BagBind b -> either id return <$> layoutBind b BagSig s@(L _ sig) -> do doc <- layoutSig s sig pure [doc] pure $ (docHandleComms epAnn, Just (docHandleComms locWhere, ds)) -- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" HsIPBinds epAnn (IPBinds _ bb) -> do ds <- mapM layoutIPBind bb pure $ (docHandleComms epAnn, Just (id, ds)) -- TODO92 do we need to replace id? EmptyLocalBinds NoExtField -> return $ (id, Nothing) layoutGrhs :: LGRHS GhcPs (LHsExpr GhcPs) -> ToBriDocM ( Maybe (EpAnn GrhsAnn) , [BriDocNumbered] , BriDocNumbered ) layoutGrhs (L _ (GRHS epAnn guards body)) = do let posArrow = obtainAnnPos epAnn AnnRarrow guardDocs <- case guards of [] -> pure [] _ -> docFlushCommsPost False posArrow $ callLayouter layout_stmt `mapM` guards let bodyEndPos = case locA $ getLoc body of GHC.RealSrcSpan s _ -> Just s GHC.UnhelpfulSpan{} -> Nothing bodyDoc <- docFlushCommsPost True bodyEndPos $ callLayouter layout_expr body return (Just 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 $ 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 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 <- 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)] -> ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered , Maybe ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered , [BriDocNumbered] ) ) -> Bool -> ToBriDocM BriDocNumbered layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauses (wrapBinds, 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 [ wrapBinds $ wrapWhere $ docLit $ Text.pack "where" , docSeparator , docForceSingleline $ return w ] , docEnsureIndent whereIndent $ docLines [ wrapBinds $ wrapWhere $ docLit $ Text.pack "where" , docEnsureIndent whereIndent $ docSetIndentLevel $ docNonBottomSpacing $ return w ] ] Just (wrapWhere, ws) -> fmap (pure . pure) $ docEnsureIndent whereIndent $ docLines [ wrapBinds $ 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 , wrapBinds $ 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 <- callLayouter layout_expr expr pure [(Nothing, [], e)] Right grhss -> layoutGrhs `mapM` grhss let multipleClauses = not $ null clauseDocs runFilteredAlternative $ do case clauseDocs of [(grhsEpAnn, guards, body)] -> do let grhsHasComms = hasAnyCommentsBelow grhsEpAnn let guardPart = docHandleComms grhsEpAnn $ singleLineGuardsDoc guards -- func x | null x = x + a + 2 where a = 1 -- or -- func x | null x = x + a + b where -- a = 1 -- b = 2 forM_ wherePart $ \wherePart' -> addAlternativeCond (not hasComments && not grhsHasComms) $ docCols (ColBindingLine alignmentToken) [ docSeq (patPartInline ++ [guardPart]) , docSeq [ appSep $ return binderDoc , docForceSingleline $ return body , wherePart' ] ] -- any below have this pattern: -- … -- where a = 1 -- or -- … -- where -- a = 1 -- b = 1 -- func x | null x = do -- stmt x addAlternativeCond (not $ maybe False startsWithComments grhsEpAnn) $ docLines $ [ docCols (ColBindingLine alignmentToken) [ docSeq (patPartInline ++ [guardPart]) , docSeq [ appSep $ return binderDoc -- TODO I did it this way just to reduce test breakage, -- but arguably we should modify tests instead. -- I _think_ we really want to drop this alternative -- when grhsHasComms , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body ] ] ] ++ wherePartMultiLine -- func x | null x = -- x + a + 2 addAlternative $ docLines $ [ docForceSingleline $ docSeq (patPartInline ++ [guardPart, return binderDoc]) , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body ] ++ wherePartMultiLine -- func x | null x -- = do -- stmt x -- log "abc" 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 -- func x | null x = -- do -- stmt1 -- stmt2 x 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 Just patDoc | multipleClauses, indentPolicy == IndentPolicyFree -> -- multiple clauses added in-paragraph, each in a single line -- func x | null x = baz -- | otherwise = asd addAlternative $ docLines $ [ docSeq [ appSep $ docForceSingleline $ return patDoc , docSetBaseY $ docLines $ clauseDocs <&> \(epAnn, guardDocs, bodyDoc) -> docHandleComms epAnn $ do 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 _ -> return () -- func x y -- | null x, null y = a + b -- | otherwise = a - b addAlternative $ docLines $ [ docAddBaseY BrIndentRegular $ patPartParWrap $ docLines $ map docSetBaseY $ clauseDocs <&> \(epAnn, guardDocs, bodyDoc) -> docHandleComms epAnn $ do 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 -- func x y -- | null x, null y = do -- stmt x -- stmt y -- | otherwise -> do -- abort addAlternativeCond (not hasComments) $ docLines $ [ docAddBaseY BrIndentRegular $ patPartParWrap $ docLines $ map docSetBaseY $ clauseDocs <&> \(grhsEpAnn, guardDocs, bodyDoc) -> -- TODO92 docHandleComms grhsEpAnn $ docSeq [ singleLineGuardsDoc guardDocs , docCols ColOpPrefix [ appSep $ return binderDoc , docAddBaseY BrIndentRegular $ docForceParSpacing $ return bodyDoc ] ] ] ++ wherePartMultiLine -- func x y -- | null x, null y -- = do -- stmt x -- stmt y -- | otherwise -- = abort addAlternative $ docLines $ [ docAddBaseY BrIndentRegular $ patPartParWrap $ docLines $ map docSetBaseY $ clauseDocs >>= \(grhsEpAnn, guardDocs, bodyDoc) -> -- TODO92 [ docHandleComms grhsEpAnn $ singleLineGuardsDoc guardDocs , docCols ColOpPrefix [ appSep $ return binderDoc , docAddBaseY BrIndentRegular $ docForceParSpacing $ return bodyDoc ] ] ] ++ wherePartMultiLine -- func x y -- | null x -- , null y -- = do -- stmt x -- stmt y -- | otherwise -- = abort addAlternative $ docLines $ [ docAddBaseY BrIndentRegular $ patPartParWrap $ docLines $ map docSetBaseY $ clauseDocs >>= \(grhsEpAnn, guardDocs, bodyDoc) -> -- TODO92 (case guardDocs of [] -> [docHandleComms grhsEpAnn docEmpty] [g] -> [ docHandleComms grhsEpAnn $ docSeq [appSep $ docLit $ Text.pack "|", return g] ] (g1 : gr) -> ( ( docHandleComms grhsEpAnn $ 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 = callLayouter layout_colsWrapPat =<< callLayouter layout_pat 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 $ callLayouter layout_type typ let hasComments = hasAnyCommentsConnected ltycl layoutLhsAndType hasComments sharedLhs (docHandleComms posEqual $ docLit $ Text.pack "=") 1 typeDoc DataDecl epAnn name tyVars _ dataDefn -> do layouters <- mAsk layout_dataDecl layouters (Just 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 $ callLayouter layout_type 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 layouters <- mAsk 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 <- callLayouter layout_tyVarBndrs bndrs docSeq ( [docLit (Text.pack "forall")] ++ layout_tyVarBndrsSingleline layouters bndrDocs ) lhs = docHandleComms epAnn $ docSeq $ [appSep instanceDoc] ++ [ makeForallDoc foralls | (HsOuterExplicit _ foralls) <- [bndrsMay] ] ++ [ docParenL | needsParens ] ++ [appSep $ docHandleComms name $ docLit nameStr] ++ intersperse docSeparator (layout_hsTyPats layouters pats) ++ [ docParenR | needsParens ] -- TODO92 hasComments <- -- (||) -- <$> hasAnyRegularCommentsConnected outerNode -- <*> hasAnyRegularCommentsRest innerNode let hasComments = hasAnyCommentsConnected outerNode typeDoc <- shareDoc $ callLayouter layout_type 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) < fmap GHC.realSrcSpanStart 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 layouters <- mAsk layout_dataDecl layouters Nothing 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 ]