hexagoxel
/
brittany
1
0
Fork 0
Code Issues 117 Pull Requests 5 Packages Projects Releases 5 Wiki Activity
brittany/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs

1006 lines
37 KiB
Haskell
Raw Blame History

{-# 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)
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 $ callLayouter layout_stmt `mapM` guards
bodyDoc <- callLayouter layout_expr 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 $ 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 <- 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 <- callLayouter layout_expr 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 = 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 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) < 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
(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
]
Reference in New Issue View Git Blame Copy Permalink