{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} module Language.Haskell.Brittany.Internal.Layouters.Decl ( layoutDecl , layoutSig , layoutBind , layoutLocalBinds , layoutGuardLStmt , layoutPatternBind , layoutGrhs , layoutPatternBindFinal ) where #include "prelude.inc" import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import Language.Haskell.Brittany.Internal.ExactPrintUtils import Language.Haskell.Brittany.Internal.Utils import GHC ( runGhc , GenLocated(L) , moduleNameString , AnnKeywordId(..) ) import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc ) import HsSyn #if MIN_VERSION_ghc(8,6,0) import HsExtension (NoExt (..)) #endif import Name import BasicTypes ( InlinePragma(..) , Activation(..) , InlineSpec(..) , RuleMatchInfo(..) #if MIN_VERSION_ghc(8,2,0) , LexicalFixity(..) #endif ) import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) import Language.Haskell.Brittany.Internal.Layouters.Type import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt import Language.Haskell.Brittany.Internal.Layouters.Pattern import Bag ( mapBagM, bagToList, emptyBag ) import Data.Char (isUpper) layoutDecl :: ToBriDoc HsDecl #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ layoutDecl d@(L loc decl) = case decl of SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case Left ns -> docLines $ return <$> ns Right n -> return n TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) InstD _ (TyFamInstD _ tfid) -> withTransformedAnns d $ layoutTyFamInstDecl False (L loc tfid) InstD _ (ClsInstD _ inst) -> withTransformedAnns d $ layoutClsInst (L loc inst) _ -> briDocByExactNoComment d #else layoutDecl d@(L loc decl) = case decl of SigD sig -> withTransformedAnns d $ layoutSig (L loc sig) ValD bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case Left ns -> docLines $ return <$> ns Right n -> return n TyClD tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) InstD (TyFamInstD tfid) -> withTransformedAnns d $ layoutTyFamInstDecl False (L loc tfid) InstD (ClsInstD inst) -> withTransformedAnns d $ layoutClsInst (L loc inst) _ -> briDocByExactNoComment d #endif -------------------------------------------------------------------------------- -- Sig -------------------------------------------------------------------------------- layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType names typ #elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ TypeSig names (HsWC _ (HsIB _ typ _)) -> layoutNamesAndType names typ #else /* ghc-8.0 */ TypeSig names (HsIB _ (HsWC _ _ typ)) -> layoutNamesAndType names typ #endif #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> #else InlineSig name (InlinePragma _ spec _arity phaseAct conlike) -> #endif docWrapNode lsig $ do nameStr <- lrdrNameToTextAnn name specStr <- specStringCompat lsig 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 ++ "] " let conlikeStr = case conlike of FunLike -> "" ConLike -> "CONLIKE " docLit $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) <> nameStr <> Text.pack " #-}" #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType names typ #elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ ClassOpSig False names (HsIB _ typ _) -> layoutNamesAndType names typ #else /* ghc-8.0 */ ClassOpSig False names (HsIB _ typ) -> layoutNamesAndType names typ #endif _ -> briDocByExactNoComment lsig -- TODO where layoutNamesAndType names typ = docWrapNode lsig $ do nameStrs <- names `forM` lrdrNameToTextAnn let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs typeDoc <- docSharedWrapper layoutType typ hasComments <- hasAnyCommentsBelow lsig shouldBeHanging <- mAsk <&> _conf_layout .> _lconfig_hangingTypeSignature .> confUnpack if shouldBeHanging then docSeq [ appSep $ docWrapNodeRest lsig $ docLit nameStr , docSetBaseY $ docLines [ docCols ColTyOpPrefix [ docLit $ Text.pack ":: " , docAddBaseY (BrIndentSpecial 3) $ typeDoc ] ] ] else layoutLhsAndType hasComments (appSep . docWrapNodeRest lsig $ docLit nameStr) "::" typeDoc specStringCompat :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String #if MIN_VERSION_ghc(8,4,0) specStringCompat ast = \case NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" Inline -> pure "INLINE " Inlinable -> pure "INLINABLE " NoInline -> pure "NOINLINE " #else specStringCompat _ = \case Inline -> pure "INLINE " Inlinable -> pure "INLINABLE " NoInline -> pure "NOINLINE " EmptyInlineSpec -> pure "" #endif layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ BodyStmt _ body _ _ -> layoutExpr body #else BodyStmt body _ _ _ -> layoutExpr body #endif #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ BindStmt _ lPat expr _ _ -> do #else BindStmt lPat expr _ _ _ -> do #endif patDoc <- docSharedWrapper layoutPat lPat expDoc <- docSharedWrapper layoutExpr expr docCols ColBindStmt [ appSep $ colsWrapPat =<< patDoc , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] ] _ -> unknownNodeError "" lgstmt -- TODO -------------------------------------------------------------------------------- -- HsBind -------------------------------------------------------------------------------- layoutBind :: ToBriDocC (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered) layoutBind lbind@(L _ bind) = case bind of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ FunBind _ fId (MG _ lmatches@(L _ matches) _) _ [] -> do #else FunBind fId (MG lmatches@(L _ matches) _ _ _) _ _ [] -> do #endif idStr <- lrdrNameToTextAnn fId binderDoc <- docLit $ Text.pack "=" funcPatDocs <- docWrapNode lbind $ docWrapNode lmatches $ layoutPatternBind (Just idStr) binderDoc `mapM` matches return $ Left $ funcPatDocs #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ PatBind _ pat (GRHSs _ grhss whereBinds) ([], []) -> do #else PatBind pat (GRHSs grhss whereBinds) _ _ ([], []) -> do #endif patDocs <- colsWrapPat =<< layoutPat pat clauseDocs <- layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds let mWhereArg = mWhereDocs <&> \d -> (mkAnnKey lbind, d) -- TODO: is this the right AnnKey? binderDoc <- docLit $ Text.pack "=" hasComments <- hasAnyCommentsBelow lbind fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing binderDoc (Just patDocs) clauseDocs mWhereArg hasComments _ -> Right <$> unknownNodeError "" lbind data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) | BagSig (LSig GhcPs) bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan bindOrSigtoSrcSpan (BagBind (L l _)) = l bindOrSigtoSrcSpan (BagSig (L l _)) = l layoutLocalBinds :: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered]) layoutLocalBinds lbinds@(L _ 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 #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsValBinds _ (ValBinds _ bindlrs sigs) -> do #else HsValBinds (ValBindsIn bindlrs sigs) -> do #endif let unordered = [ BagBind b | b <- Data.Foldable.toList bindlrs ] ++ [ BagSig s | s <- sigs ] ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered docs <- docWrapNode lbinds $ join <$> ordered `forM` \case BagBind b -> either id return <$> layoutBind b BagSig s -> return <$> layoutSig s return $ Just $ docs #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ -- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" XHsLocalBindsLR{} -> error "brittany internal error: XHsLocalBindsLR" #else x@(HsValBinds (ValBindsOut _binds _lsigs)) -> -- i _think_ this case never occurs in non-processed ast Just . (: []) <$> unknownNodeError "HsValBinds ValBindsOut{}" (L noSrcSpan x) #endif x@(HsIPBinds{}) -> Just . (: []) <$> unknownNodeError "HsIPBinds" (L noSrcSpan x) EmptyLocalBinds{} -> return $ Nothing -- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is -- parSpacing stuff.B layoutGrhs :: LGRHS GhcPs (LHsExpr GhcPs) -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs) #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do #else layoutGrhs lgrhs@(L _ (GRHS guards body)) = do #endif guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards bodyDoc <- layoutExpr body return (guardDocs, bodyDoc, body) #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ layoutGrhs (L _ (XGRHS{})) = error "brittany internal error: XGRHS" #endif layoutPatternBind :: Maybe Text -> BriDocNumbered -> LMatch GhcPs (LHsExpr GhcPs) -> ToBriDocM BriDocNumbered layoutPatternBind funId binderDoc lmatch@(L _ match) = do let pats = m_pats match #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ let (GRHSs _ grhss whereBinds) = m_grhss match #else let (GRHSs grhss whereBinds) = m_grhss match #endif patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p let isInfix = isInfixMatch match mIdStr <- case match of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ Match _ (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId #elif MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ Match (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId #elif MIN_VERSION_ghc(8,2,0) /* ghc-8.4 */ Match (FunRhs matchId _ _) _ _ _ -> Just <$> lrdrNameToTextAnn matchId #else Match (FunBindMatch matchId _) _ _ _ -> Just <$> lrdrNameToTextAnn matchId #endif _ -> pure Nothing let mIdStr' = fixPatternBindIdentifier match <$> mIdStr patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of (Just idStr, p1 : pr) | isInfix -> docCols ColPatternsFuncInfix ( [appSep $ docForceSingleline p1, appSep $ docLit idStr] ++ (spacifyDocs $ docForceSingleline <$> pr) ) (Just idStr, []) -> docLit idStr (Just idStr, ps) -> docCols ColPatternsFuncPrefix $ appSep (docLit $ idStr) : (spacifyDocs $ docForceSingleline <$> ps) (Nothing, ps) -> docCols ColPatterns $ (List.intersperse docSeparator $ docForceSingleline <$> ps) clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds let mWhereArg = mWhereDocs <&> \d -> (mkAnnKey lmatch, d) let alignmentToken = if null pats then Nothing else funId hasComments <- hasAnyCommentsBelow lmatch layoutPatternBindFinal alignmentToken binderDoc (Just patDoc) clauseDocs mWhereArg hasComments #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 && ghc-8.4 */ 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 #else /* ghc-8.0 */ fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text fixPatternBindIdentifier _ x = x #endif layoutPatternBindFinal :: Maybe Text -> BriDocNumbered -> Maybe BriDocNumbered -> [([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)] -> Maybe (ExactPrint.AnnKey, [BriDocNumbered]) -- ^ AnnKey for the node that contains the AnnWhere position annotation -> Bool -> ToBriDocM BriDocNumbered layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs 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 (annKeyWhere, [w]) -> fmap (pure . pure) $ docAlt [ docEnsureIndent BrIndentRegular $ docSeq [ docLit $ Text.pack "where" , docSeparator , docForceSingleline $ return w ] , docMoveToKWDP annKeyWhere AnnWhere False $ docEnsureIndent whereIndent $ docLines [ docLit $ Text.pack "where" , docEnsureIndent whereIndent $ docSetIndentLevel $ docNonBottomSpacing $ return w ] ] Just (annKeyWhere, ws) -> fmap (pure . pure) $ docMoveToKWDP annKeyWhere AnnWhere False $ docEnsureIndent whereIndent $ docLines [ 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 (_, [w]) -> Just $ docSeq [ docSeparator , appSep $ docLit $ Text.pack "where" , docSetIndentLevel $ docForceSingleline $ return w ] _ -> Nothing indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack runFilteredAlternative $ do case clauseDocs of [(guards, body, _bodyRaw)] -> do let guardPart = 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 $ 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 <&> \(guardDocs, bodyDoc, _) -> 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 -- multiple clauses, each in a separate, single line addAlternative $ docLines $ [ docAddBaseY BrIndentRegular $ patPartParWrap $ docLines $ map docSetBaseY $ clauseDocs <&> \(guardDocs, bodyDoc, _) -> 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 -- multiple clauses, each with the guard(s) in a single line, body -- as a paragraph addAlternative $ docLines $ [ docAddBaseY BrIndentRegular $ patPartParWrap $ docLines $ map docSetBaseY $ clauseDocs <&> \(guardDocs, bodyDoc, _) -> 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 >>= \(guardDocs, bodyDoc, _) -> ( case guardDocs of [] -> [] [g] -> [ docForceSingleline $ docSeq [appSep $ docLit $ Text.pack "|", return g] ] gs -> [ 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 >>= \(guardDocs, bodyDoc, _) -> ( case guardDocs of [] -> [] [g] -> [docSeq [appSep $ docLit $ Text.pack "|", return g]] (g1:gr) -> ( 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 -------------------------------------------------------------------------------- -- TyClDecl -------------------------------------------------------------------------------- layoutTyCl :: ToBriDoc TyClDecl layoutTyCl ltycl@(L _loc tycl) = case tycl of #if MIN_VERSION_ghc(8,6,0) SynDecl _ name vars fixity typ -> do let isInfix = case fixity of Prefix -> False Infix -> True #elif MIN_VERSION_ghc(8,2,0) SynDecl name vars fixity typ _ -> do let isInfix = case fixity of Prefix -> False Infix -> True #else SynDecl name vars typ _ -> do nameStr <- lrdrNameToTextAnn name let isInfixTypeOp = case Text.uncons nameStr of Nothing -> False Just (c, _) -> not (c == '(' || isUpper c) isInfix <- (isInfixTypeOp ||) <$> hasAnnKeyword name AnnBackquote #endif -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP -- let parenWrapper = if hasTrailingParen -- then appSep . docWrapNodeRest ltycl -- else id let wrapNodeRest = docWrapNodeRest ltycl docWrapNodePrior ltycl $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ _ -> briDocByExactNoComment ltycl layoutSynDecl :: Bool -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) -> Located (IdP GhcPs) -> [LHsTyVarBndr GhcPs] -> LHsType GhcPs -> ToBriDocM BriDocNumbered layoutSynDecl isInfix wrapNodeRest name vars typ = do nameStr <- lrdrNameToTextAnn name let lhs = appSep . wrapNodeRest $ if isInfix then do let (a : b : rest) = vars hasOwnParens <- hasAnnKeywordComment a AnnOpenP -- This isn't quite right, but does give syntactically valid results let needsParens = not $ null rest || hasOwnParens 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 , docWrapNode name $ docLit nameStr ] ++ fmap (layoutTyVarBndr True) vars sharedLhs <- docSharedWrapper id lhs typeDoc <- docSharedWrapper layoutType typ hasComments <- hasAnyCommentsConnected typ layoutLhsAndType hasComments sharedLhs "=" typeDoc layoutTyVarBndr :: Bool -> ToBriDoc HsTyVarBndr layoutTyVarBndr needsSep lbndr@(L _ bndr) = do docWrapNodePrior lbndr $ case bndr of #if MIN_VERSION_ghc(8,6,0) /* 8.6 */ XTyVarBndr{} -> error "brittany internal error: XTyVarBndr" UserTyVar _ name -> do #else /* 8.0 8.2 8.4 */ UserTyVar name -> do #endif nameStr <- lrdrNameToTextAnn name docSeq $ [docSeparator | needsSep] ++ [docLit nameStr] #if MIN_VERSION_ghc(8,6,0) /* 8.6 */ KindedTyVar _ name kind -> do #else /* 8.0 8.2 8.4 */ KindedTyVar name kind -> do #endif nameStr <- lrdrNameToTextAnn name docSeq $ [ docSeparator | needsSep ] ++ [ docLit $ Text.pack "(" , appSep $ docLit nameStr , appSep . docLit $ Text.pack "::" , docForceSingleline $ layoutType kind , docLit $ Text.pack ")" ] -------------------------------------------------------------------------------- -- TyFamInstDecl -------------------------------------------------------------------------------- layoutTyFamInstDecl :: Bool -> ToBriDoc TyFamInstDecl layoutTyFamInstDecl inClass (L loc tfid) = do let #if MIN_VERSION_ghc(8,6,0) linst = L loc (TyFamInstD NoExt tfid) feqn@(FamEqn _ name pats _fixity typ) = hsib_body $ tfid_eqn tfid lfeqn = L loc feqn #elif MIN_VERSION_ghc(8,4,0) linst = L loc (TyFamInstD tfid) feqn@(FamEqn name pats _fixity typ) = hsib_body $ tfid_eqn tfid lfeqn = L loc feqn #elif MIN_VERSION_ghc(8,2,0) linst = L loc (TyFamInstD tfid) lfeqn@(L _ (TyFamEqn name boundPats _fixity typ)) = tfid_eqn tfid pats = hsib_body boundPats #else linst = L loc (TyFamInstD tfid) lfeqn@(L _ (TyFamEqn name boundPats typ)) = tfid_eqn tfid pats = hsib_body boundPats #endif docWrapNodePrior linst $ do nameStr <- lrdrNameToTextAnn name needsParens <- hasAnnKeyword lfeqn AnnOpenP let instanceDoc = if inClass then docLit $ Text.pack "type" else docSeq [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"] lhs = docWrapNode lfeqn . appSep . docWrapNodeRest linst . docSeq $ (appSep instanceDoc :) $ [ docParenL | needsParens ] ++ [appSep $ docWrapNode name $ docLit nameStr] ++ intersperse docSeparator (layoutType <$> pats) ++ [ docParenR | needsParens ] hasComments <- (||) <$> hasAnyRegularCommentsConnected lfeqn <*> hasAnyRegularCommentsRest linst typeDoc <- docSharedWrapper layoutType typ layoutLhsAndType hasComments lhs "=" 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 :: ToBriDoc ClsInstDecl layoutClsInst lcid@(L _ cid) = docLines [ layoutInstanceHead , docEnsureIndent BrIndentRegular $ 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 #if MIN_VERSION_ghc(8,6,0) /* 8.6 */ layoutInstanceHead = briDocByExactNoComment $ InstD NoExt . ClsInstD NoExt . removeChildren <$> lcid #else layoutInstanceHead = briDocByExactNoComment $ InstD . ClsInstD . removeChildren <$> lcid #endif removeChildren :: ClsInstDecl p -> ClsInstDecl p 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 . BDFLines . fmap unLoc . List.sortOn getLoc =<< sequence l layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig layoutAndLocateBind :: ToBriDocC (HsBind GhcPs) (Located BriDocNumbered) layoutAndLocateBind lbind@(L 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 GhcPs) (Located BriDocNumbered) layoutAndLocateTyFamInsts ltfid@(L loc _) = L loc <$> layoutTyFamInstDecl True ltfid layoutAndLocateDataFamInsts :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered) layoutAndLocateDataFamInsts ldfid@(L loc _) = L loc <$> layoutDataFamInstDecl ldfid -- | Send to ExactPrint then remove unecessary whitespace layoutDataFamInstDecl :: ToBriDoc DataFamInstDecl layoutDataFamInstDecl ldfid = fmap stripWhitespace <$> briDocByExactNoComment ldfid -- | ExactPrint adds indentation/newlines to @data@/@type@ declarations stripWhitespace :: BriDocF f -> BriDocF f stripWhitespace (BDFExternal ann anns b t) = BDFExternal ann anns b $ stripWhitespace' t stripWhitespace b = b -- | This fixes two issues of output coming from Exactprinting -- associated (data) type decls. Firstly we place the output into docLines, -- so one newline coming from Exactprint is superfluous, so we drop the -- first (empty) line. The second issue is Exactprint indents the first -- member in a strange fashion: -- -- input: -- -- > instance MyClass Int where -- > -- | This data is very important -- > data MyData = IntData -- > { intData :: String -- > , intData2 :: Int -- > } -- -- output of just exactprinting the associated data type syntax node -- -- > -- > -- | This data is very important -- > data MyData = IntData -- > { intData :: String -- > , intData2 :: Int -- > } -- -- To fix this, we strip whitespace from the start of the comments and the -- first line of the declaration, stopping when we see "data" or "type" at -- the start of a line. I.e., this function yields -- -- > -- | This data is very important -- > data MyData = IntData -- > { intData :: String -- > , intData2 :: Int -- > } -- -- Downside apart from being a hacky and brittle fix is that this removes -- possible additional indentation from comments before the first member. -- -- But the whole thing is just a temporary measure until brittany learns -- to layout data/type decls. stripWhitespace' :: Text -> Text stripWhitespace' t = Text.intercalate (Text.pack "\n") $ go $ List.drop 1 $ Text.lines t where go [] = [] go (line1 : lineR) = case Text.stripStart line1 of st | isTypeOrData st -> st : lineR | otherwise -> st : go lineR isTypeOrData t' = (Text.pack "type" `Text.isPrefixOf` t') || (Text.pack "data" `Text.isPrefixOf` t') -------------------------------------------------------------------------------- -- Common Helpers -------------------------------------------------------------------------------- layoutLhsAndType :: Bool -> ToBriDocM BriDocNumbered -> String -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered layoutLhsAndType hasComments lhs sep typeDoc = do let sepDoc = appSep . docLit $ Text.pack sep runFilteredAlternative $ do -- (separators probably are "=" or "::") -- lhs = type -- lhs :: type addAlternativeCond (not hasComments) $ docSeq [lhs, sepDoc, docForceSingleline typeDoc] -- lhs -- :: typeA -- -> typeB -- lhs -- = typeA -- -> typeB addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols ColTyOpPrefix [sepDoc, docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc]