317 lines
13 KiB
Haskell
317 lines
13 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
|
|
module Language.Haskell.Brittany.Internal.S4_WriteBriDoc
|
|
( ppBriDoc
|
|
)
|
|
where
|
|
|
|
import Language.Haskell.Brittany.Internal.Prelude
|
|
|
|
import qualified Control.Monad.Trans.MultiRWS.Strict
|
|
as MultiRWSS
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Lazy.Builder as TextL.Builder
|
|
import GHC ( Anchor(Anchor)
|
|
, AnchorOperation
|
|
( MovedAnchor
|
|
, UnchangedAnchor
|
|
)
|
|
, EpaComment(EpaComment)
|
|
, EpaCommentTok
|
|
( EpaBlockComment
|
|
, EpaDocCommentNamed
|
|
, EpaDocCommentNext
|
|
, EpaDocCommentPrev
|
|
, EpaDocOptions
|
|
, EpaDocSection
|
|
, EpaEofComment
|
|
, EpaLineComment
|
|
)
|
|
, GenLocated(L)
|
|
, LEpaComment
|
|
, RealSrcLoc
|
|
)
|
|
import GHC.Types.SrcLoc ( realSrcSpanEnd )
|
|
import qualified GHC.OldList as List
|
|
|
|
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint
|
|
|
|
import Language.Haskell.Brittany.Internal.Config.Types
|
|
import Language.Haskell.Brittany.Internal.Transformations.T1_Alt
|
|
import Language.Haskell.Brittany.Internal.Transformations.T2_Floating
|
|
import Language.Haskell.Brittany.Internal.Transformations.T3_Par
|
|
import Language.Haskell.Brittany.Internal.Transformations.T4_Columns
|
|
import Language.Haskell.Brittany.Internal.Transformations.T5_Indent
|
|
import Language.Haskell.Brittany.Internal.Types
|
|
import Language.Haskell.Brittany.Internal.Utils
|
|
import Language.Haskell.Brittany.Internal.WriteBriDoc.AlignmentAlgo
|
|
import Language.Haskell.Brittany.Internal.WriteBriDoc.Types
|
|
import Language.Haskell.Brittany.Internal.WriteBriDoc.Operators
|
|
import Language.Haskell.Brittany.Internal.Components.BriDoc
|
|
-- import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
|
|
|
|
|
|
ppBriDoc :: BriDocNumbered -> PPMLocal ()
|
|
ppBriDoc briDoc = do
|
|
-- first step: transform the briDoc.
|
|
briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do
|
|
-- Note that briDoc is BriDocNumbered, but state type is BriDoc.
|
|
-- That's why the alt-transform looks a bit special here.
|
|
traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw
|
|
$ briDocToDoc
|
|
$ unwrapBriDocNumbered
|
|
$ briDoc
|
|
-- bridoc transformation: remove alts
|
|
transformAlts briDoc >>= mSet
|
|
mGet
|
|
>>= briDocToDoc
|
|
.> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt
|
|
-- bridoc transformation: float stuff in
|
|
mGet >>= transformSimplifyFloating .> mSet
|
|
mGet
|
|
>>= briDocToDoc
|
|
.> traceIfDumpConf "bridoc post-floating"
|
|
_dconf_dump_bridoc_simpl_floating
|
|
-- bridoc transformation: par removal
|
|
mGet >>= transformSimplifyPar .> mSet
|
|
mGet
|
|
>>= briDocToDoc
|
|
.> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par
|
|
-- bridoc transformation: float stuff in
|
|
mGet >>= transformSimplifyColumns .> mSet
|
|
mGet
|
|
>>= briDocToDoc
|
|
.> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns
|
|
-- bridoc transformation: indent
|
|
mGet >>= transformSimplifyIndent .> mSet
|
|
mGet
|
|
>>= briDocToDoc
|
|
.> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent
|
|
mGet
|
|
>>= briDocToDoc
|
|
.> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final
|
|
-- -- convert to Simple type
|
|
-- simpl <- mGet <&> transformToSimple
|
|
-- return simpl
|
|
|
|
let state = LayoutState { _lstate_baseYs = [0]
|
|
, _lstate_curY = 0
|
|
, _lstate_indLevels = [0]
|
|
, _lstate_indLevelLinger = 0
|
|
, _lstate_plannedSpace = PlannedNone
|
|
, _lstate_commentNewlines = 0
|
|
}
|
|
state' <-
|
|
MultiRWSS.withMultiStateS state
|
|
$ MultiRWSS.withMultiStateS ([] :: [LEpaComment])
|
|
$ do
|
|
layoutBriDocM briDoc'
|
|
case _lstate_plannedSpace state' of
|
|
PlannedNone -> if _lstate_curY state' == 0
|
|
then pure ()
|
|
else mTell $ TextL.Builder.fromString "\n"
|
|
PlannedSameline _ -> if _lstate_curY state' == 0
|
|
then pure ()
|
|
else mTell $ TextL.Builder.fromString "\n"
|
|
PlannedNewline l -> mTell $ TextL.Builder.fromString (replicate l '\n')
|
|
PlannedDelta l _ -> mTell $ TextL.Builder.fromString (replicate l '\n')
|
|
|
|
|
|
layoutBriDocM :: HasCallStack => forall m . LayoutConstraints m => BriDoc -> m ()
|
|
layoutBriDocM = \case
|
|
BDEmpty -> do
|
|
return () -- can it be that simple
|
|
BDLit t -> do
|
|
layoutRemoveIndentLevelLinger
|
|
layoutWriteAppend t
|
|
BDSeq list -> do
|
|
list `forM_` layoutBriDocM
|
|
-- in this situation, there is nothing to do about cols.
|
|
-- i think this one does not happen anymore with the current simplifications.
|
|
-- BDCols cSig list | BDPar sameLine lines <- List.last list ->
|
|
-- alignColsPar $ BDCols cSig (List.init list ++ [sameLine]) : lines
|
|
BDCols _ list -> do
|
|
list `forM_` layoutBriDocM
|
|
BDSeparator -> do
|
|
layoutAddSepSpace
|
|
BDAddBaseY indent bd -> do
|
|
let indentF = case indent of
|
|
BrIndentNone -> id
|
|
BrIndentRegular -> layoutWithAddBaseCol
|
|
BrIndentSpecial i -> layoutWithAddBaseColN i
|
|
indentF $ layoutBriDocM bd
|
|
BDBaseYPushCur bd -> do
|
|
layoutBaseYPushCur
|
|
layoutBriDocM bd
|
|
BDBaseYPop bd -> do
|
|
layoutBriDocM bd
|
|
layoutBaseYPop
|
|
BDIndentLevelPushCur bd -> do
|
|
layoutIndentLevelPushCur
|
|
layoutBriDocM bd
|
|
BDIndentLevelPop bd -> do
|
|
layoutBriDocM bd
|
|
layoutIndentLevelPop
|
|
BDEnsureIndent indent bd -> do
|
|
let indentF = case indent of
|
|
BrIndentNone -> id
|
|
BrIndentRegular -> layoutWithAddBaseCol
|
|
BrIndentSpecial i -> layoutWithAddBaseColN i
|
|
indentF $ do
|
|
layoutWriteEnsureBlock
|
|
layoutBriDocM bd
|
|
BDPar indent sameLine indented -> do
|
|
layoutBriDocM sameLine
|
|
let indentF = case indent of
|
|
BrIndentNone -> id
|
|
BrIndentRegular -> layoutWithAddBaseCol
|
|
BrIndentSpecial i -> layoutWithAddBaseColN i
|
|
indentF $ do
|
|
layoutWriteNewline
|
|
layoutBriDocM indented
|
|
BDLines lines -> alignColsLines layoutBriDocM lines
|
|
BDAlt [] -> error "empty BDAlt"
|
|
BDAlt (alt : _) -> layoutBriDocM alt
|
|
BDForceMultiline bd -> layoutBriDocM bd
|
|
BDForceSingleline bd -> layoutBriDocM bd
|
|
BDForwardLineMode bd -> layoutBriDocM bd
|
|
BDExternal shouldAddComment t -> do
|
|
let tlines = Text.lines $ t <> Text.pack "\n"
|
|
tlineCount = length tlines
|
|
when shouldAddComment $ do
|
|
layoutWriteAppend $ Text.pack $ "{- via external! -}"
|
|
zip [1 ..] tlines `forM_` \(i, l) -> do
|
|
layoutWriteAppend $ l
|
|
unless (i == tlineCount) layoutWriteNewline
|
|
BDPlain t -> do
|
|
layoutWriteAppend t
|
|
-- BDAnnotationPrior comms bd -> do
|
|
-- -- state <- mGet
|
|
-- -- let m = _lstate_comments state
|
|
-- -- let
|
|
-- -- moveToExactLocationAction = case _lstate_curYOrAddNewline state of
|
|
-- -- Left{} -> pure ()
|
|
-- -- Right{} -> moveToExactAnn annKey
|
|
-- -- case mAnn of
|
|
-- -- Nothing -> moveToExactLocationAction
|
|
-- -- Just [] -> moveToExactLocationAction
|
|
-- -- Just priors -> do
|
|
-- -- -- layoutResetSepSpace
|
|
-- -- priors
|
|
-- -- `forM_` \(ExactPrint.Types.Comment comment _ _, DifferentLine (y, x)) ->
|
|
-- -- when (comment /= "(" && comment /= ")") $ do
|
|
-- -- let commentLines = Text.lines $ Text.pack $ comment
|
|
-- -- case comment of
|
|
-- -- ('#' : _) ->
|
|
-- -- layoutMoveToCommentPos y (-999) (length commentLines)
|
|
-- -- -- ^ evil hack for CPP
|
|
-- -- _ -> layoutMoveToCommentPos y x (length commentLines)
|
|
-- -- -- fixedX <- fixMoveToLineByIsNewline x
|
|
-- -- -- replicateM_ fixedX layoutWriteNewline
|
|
-- -- -- layoutMoveToIndentCol y
|
|
-- -- layoutWriteAppendMultiline commentLines
|
|
-- -- -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
|
|
-- -- moveToExactLocationAction
|
|
-- printComments comms
|
|
-- mModify (\s -> s + CommentCounter (length comms))
|
|
-- layoutBriDocM bd
|
|
-- BDAnnotationPost comms bd -> do
|
|
-- layoutBriDocM bd
|
|
-- printComments comms
|
|
-- mModify (\s -> s + CommentCounter (length comms))
|
|
-- annMay <- do
|
|
-- state <- mGet
|
|
-- let m = _lstate_comments state
|
|
-- pure $ Map.lookup annKey m
|
|
-- let mComments = nonEmpty . extractAllComments =<< annMay
|
|
-- -- let
|
|
-- -- semiCount = length
|
|
-- -- [ ()
|
|
-- -- | Just ann <- [annMay]
|
|
-- -- , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann
|
|
-- -- ]
|
|
-- shouldAddSemicolonNewlines <-
|
|
-- mAsk
|
|
-- <&> _conf_layout
|
|
-- .> _lconfig_experimentalSemicolonNewlines
|
|
-- .> confUnpack
|
|
-- case mComments of
|
|
-- Nothing -> do
|
|
-- when shouldAddSemicolonNewlines $ do
|
|
-- [1 .. semiCount] `forM_` const layoutWriteNewline
|
|
-- Just comments -> do
|
|
-- comments
|
|
-- `forM_` \(ExactPrint.Types.Comment comment _ _, DifferentLine (y, x)) ->
|
|
-- when (comment /= "(" && comment /= ")") $ do
|
|
-- let commentLines = Text.lines $ Text.pack comment
|
|
-- case comment of
|
|
-- ('#' : _) -> layoutMoveToCommentPos y (-999) 1
|
|
-- -- ^ evil hack for CPP
|
|
-- ")" -> pure ()
|
|
-- -- ^ fixes the formatting of parens
|
|
-- -- on the lhs of type alias defs
|
|
-- _ -> layoutMoveToCommentPos y x (length commentLines)
|
|
-- -- fixedX <- fixMoveToLineByIsNewline x
|
|
-- -- replicateM_ fixedX layoutWriteNewline
|
|
-- -- layoutMoveToIndentCol y
|
|
-- layoutWriteAppendMultiline commentLines
|
|
-- -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
|
|
BDQueueComments comms bd -> do
|
|
existing :: [GHC.LEpaComment] <- mGet
|
|
mSet $ mergeOn (\(L l _) -> l) existing comms
|
|
layoutBriDocM bd
|
|
BDFlushCommentsPrior loc bd -> do
|
|
comms <- takeBefore loc
|
|
printComments comms
|
|
mModify (\s -> s + CommentCounter (length comms))
|
|
layoutBriDocM bd
|
|
BDFlushCommentsPost loc bd -> do
|
|
layoutBriDocM bd
|
|
comms <- takeBefore loc
|
|
mModify (\s -> s + CommentCounter (length comms))
|
|
printComments comms
|
|
BDNonBottomSpacing _ bd -> layoutBriDocM bd
|
|
BDSetParSpacing bd -> layoutBriDocM bd
|
|
BDForceParSpacing bd -> layoutBriDocM bd
|
|
BDDebug s bd -> do
|
|
mTell $ TextL.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}"
|
|
layoutBriDocM bd
|
|
|
|
mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a]
|
|
mergeOn _f xs [] = xs
|
|
mergeOn _f [] ys = ys
|
|
mergeOn f xs@(x:xr) ys@(y:yr)
|
|
| f x <= f y = x : mergeOn f xr ys
|
|
| otherwise = y : mergeOn f xs yr
|
|
|
|
takeBefore
|
|
:: MonadMultiState [LEpaComment] m => RealSrcLoc -> m [LEpaComment]
|
|
takeBefore loc = do
|
|
comms <- mGet
|
|
let (before, after) = List.span
|
|
(\(L (Anchor spanC _) _) -> realSrcSpanEnd spanC <= loc)
|
|
comms
|
|
mSet after
|
|
pure before
|
|
|
|
printComments :: LayoutConstraints m => [GHC.LEpaComment] -> m ()
|
|
printComments comms = do
|
|
let addComment s anchor prior = do
|
|
case anchor of
|
|
Anchor span UnchangedAnchor -> layoutWriteComment
|
|
True
|
|
(ExactPrint.ss2deltaEnd prior span)
|
|
1
|
|
(Text.pack s)
|
|
Anchor _span (MovedAnchor dp) ->
|
|
layoutWriteComment False dp 1 (Text.pack s)
|
|
comms `forM_` \case
|
|
L anch (EpaComment (EpaDocCommentNext s) prior) -> addComment s anch prior
|
|
L anch (EpaComment (EpaDocCommentPrev s) prior) -> addComment s anch prior
|
|
L anch (EpaComment (EpaDocCommentNamed s) prior) -> addComment s anch prior
|
|
L anch (EpaComment (EpaDocSection _ s) prior) -> addComment s anch prior
|
|
L anch (EpaComment (EpaDocOptions s) prior) -> addComment s anch prior
|
|
L anch (EpaComment (EpaLineComment s) prior) -> addComment s anch prior
|
|
L anch (EpaComment (EpaBlockComment s) prior) -> addComment s anch prior
|
|
L _anch (EpaComment (EpaEofComment) _prior) -> pure ()
|