{-# LANGUAGE OverloadedStrings #-}
module Ormolu.Printer.Comments
( spitPrecedingComments,
spitFollowingComments,
spitRemainingComments,
spitStackHeader,
)
where
import Control.Monad
import Data.Char (isSpace)
import Data.Coerce (coerce)
import Data.Data (Data)
import Data.List (isPrefixOf)
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Text as T
import Ormolu.Parser.CommentStream
import Ormolu.Printer.Internal
import Ormolu.Utils (isModule)
import SrcLoc
spitPrecedingComments ::
Data a =>
RealLocated a ->
R ()
spitPrecedingComments ref = do
gotSome <- handleCommentSeries (spitPrecedingComment ref)
when gotSome $ do
lastSpn <- fmap snd <$> getLastCommentSpan
when (needsNewlineBefore (getRealSrcSpan ref) lastSpn) newline
spitFollowingComments ::
Data a =>
RealLocated a ->
R ()
spitFollowingComments ref = do
trimSpanStream (getRealSrcSpan ref)
void $ handleCommentSeries (spitFollowingComment ref)
spitRemainingComments :: R ()
spitRemainingComments = void $ handleCommentSeries spitRemainingComment
spitStackHeader :: R ()
spitStackHeader = do
let isStackHeader (Comment (x :| _)) =
"stack" `isPrefixOf` dropWhile isSpace (drop 2 x)
mstackHeader <- popComment (isStackHeader . unRealSrcSpan)
forM_ mstackHeader $ \(L spn x) -> do
spitCommentNow spn x
newline
spitPrecedingComment ::
Data a =>
RealLocated a ->
Maybe RealSrcSpan ->
R Bool
spitPrecedingComment (L ref a) mlastSpn = do
let p (L l _) = realSrcSpanEnd l <= realSrcSpanStart ref
withPoppedComment p $ \l comment -> do
dirtyLine <-
case mlastSpn of
Nothing -> isLineDirty
Just _ -> return False
when (dirtyLine || needsNewlineBefore l mlastSpn) newline
spitCommentNow l comment
if theSameLinePre l ref && not (isModule a)
then space
else newline
spitFollowingComment ::
Data a =>
RealLocated a ->
Maybe RealSrcSpan ->
R Bool
spitFollowingComment (L ref a) mlastSpn = do
mnSpn <- nextEltSpan
meSpn <- getEnclosingSpan (/= ref)
withPoppedComment (commentFollowsElt ref mnSpn meSpn mlastSpn) $ \l comment ->
if theSameLinePost l ref && not (isModule a)
then
if isMultilineComment comment
then space >> spitCommentNow l comment
else spitCommentPending OnTheSameLine l comment
else do
when (needsNewlineBefore l mlastSpn) $
registerPendingCommentLine OnNextLine ""
spitCommentPending OnNextLine l comment
spitRemainingComment ::
Maybe RealSrcSpan ->
R Bool
spitRemainingComment mlastSpn =
withPoppedComment (const True) $ \l comment -> do
when (needsNewlineBefore l mlastSpn) newline
spitCommentNow l comment
newline
handleCommentSeries ::
(Maybe RealSrcSpan -> R Bool) ->
R Bool
handleCommentSeries f = go False
where
go gotSome = do
done <- getLastCommentSpan >>= f . fmap snd
if done
then return gotSome
else go True
withPoppedComment ::
(RealLocated Comment -> Bool) ->
(RealSrcSpan -> Comment -> R ()) ->
R Bool
withPoppedComment p f = do
r <- popComment p
case r of
Nothing -> return True
Just (L l comment) -> False <$ f l comment
needsNewlineBefore ::
RealSrcSpan ->
Maybe RealSrcSpan ->
Bool
needsNewlineBefore l mlastSpn =
case mlastSpn of
Nothing -> False
Just lastSpn ->
srcSpanStartLine l > srcSpanEndLine lastSpn + 1
theSameLinePre ::
RealSrcSpan ->
RealSrcSpan ->
Bool
theSameLinePre l ref =
srcSpanEndLine l == srcSpanStartLine ref
theSameLinePost ::
RealSrcSpan ->
RealSrcSpan ->
Bool
theSameLinePost l ref =
srcSpanStartLine l == srcSpanEndLine ref
commentFollowsElt ::
RealSrcSpan ->
Maybe RealSrcSpan ->
Maybe RealSrcSpan ->
Maybe RealSrcSpan ->
RealLocated Comment ->
Bool
commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =
goesAfter
&& logicallyFollows
&& noEltBetween
&& (continuation || lastInEnclosing || supersedesParentElt)
where
goesAfter =
realSrcSpanStart l >= realSrcSpanEnd ref
logicallyFollows =
theSameLinePost l ref
|| isPrevHaddock comment
|| continuation
|| lastInEnclosing
noEltBetween =
case mnSpn of
Nothing -> True
Just nspn ->
realSrcSpanStart nspn >= realSrcSpanEnd l
supersedesParentElt =
case meSpn of
Nothing -> True
Just espn ->
let startColumn = srcLocCol . realSrcSpanStart
in startColumn espn > startColumn ref
|| ( abs (startColumn espn - startColumn l)
>= abs (startColumn ref - startColumn l)
)
continuation =
case mlastSpn of
Nothing -> False
Just spn -> srcSpanEndLine spn + 1 == srcSpanStartLine l
lastInEnclosing =
case meSpn of
Nothing -> False
Just espn ->
let
insideParent = realSrcSpanEnd l <= realSrcSpanEnd espn
nextOutsideParent = case mnSpn of
Nothing -> True
Just nspn -> realSrcSpanEnd espn < realSrcSpanStart nspn
in insideParent && nextOutsideParent
spitCommentNow :: RealSrcSpan -> Comment -> R ()
spitCommentNow spn comment = do
sitcc
. sequence_
. NE.intersperse newline
. fmap (txt . T.pack)
. coerce
$ comment
setLastCommentSpan Nothing spn
spitCommentPending :: CommentPosition -> RealSrcSpan -> Comment -> R ()
spitCommentPending position spn comment = do
let wrapper = case position of
OnTheSameLine -> sitcc
OnNextLine -> id
wrapper
. sequence_
. NE.toList
. fmap (registerPendingCommentLine position . T.pack)
. coerce
$ comment
setLastCommentSpan Nothing spn