1008 lines
37 KiB
Haskell
1008 lines
37 KiB
Haskell
{-# 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) =
|
|
docHandleComms lmatch $ do
|
|
let pats = m_pats match
|
|
let (GRHSs _ grhss whereBinds) = m_grhss 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 match of
|
|
Match epAnn (FunRhs matchId _ _) _ _ ->
|
|
fmap Just
|
|
$ docHandleComms epAnn $ 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
|
|
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 ->
|
|
docHandleComms epAnn $ layoutDataDecl ltycl 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
|
|
docHandleComms epAnn $ layoutDataDecl
|
|
(error "Unsupported form of DataFamInstDecl")
|
|
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
|
|
]
|