{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Ormolu.Printer.Comments
( spitPrecedingComments,
spitFollowingComments,
spitRemainingComments,
spitCommentNow,
spitCommentPending,
)
where
import Control.Monad
import qualified Data.List.NonEmpty as NE
import Data.Maybe (listToMaybe)
import qualified Data.Text as T
import GHC.Types.SrcLoc
import Ormolu.Parser.CommentStream
import Ormolu.Printer.Internal
spitPrecedingComments ::
RealSrcSpan ->
R ()
RealSrcSpan
ref = do
Bool
gotSome <- R Bool -> R Bool
handleCommentSeries (RealSrcSpan -> R Bool
spitPrecedingComment RealSrcSpan
ref)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
gotSome forall a b. (a -> b) -> a -> b
$ do
Maybe SpanMark
lastMark <- R (Maybe SpanMark)
getSpanMark
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RealSrcSpan -> Maybe SpanMark -> Bool
needsNewlineBefore RealSrcSpan
ref Maybe SpanMark
lastMark) R ()
newline
spitFollowingComments ::
RealSrcSpan ->
R ()
RealSrcSpan
ref = do
RealSrcSpan -> R ()
trimSpanStream RealSrcSpan
ref
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ R Bool -> R Bool
handleCommentSeries (RealSrcSpan -> R Bool
spitFollowingComment RealSrcSpan
ref)
spitRemainingComments :: R ()
spitRemainingComments :: R ()
spitRemainingComments = do
R ()
newline
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ R Bool -> R Bool
handleCommentSeries R Bool
spitRemainingComment
spitPrecedingComment ::
RealSrcSpan ->
R Bool
RealSrcSpan
ref = do
Maybe SpanMark
mlastMark <- R (Maybe SpanMark)
getSpanMark
let p :: GenLocated RealSrcSpan e -> Bool
p (L RealSrcSpan
l e
_) = RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
l forall a. Ord a => a -> a -> Bool
<= RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
ref
(RealLocated Comment -> Bool)
-> (RealSrcSpan -> Comment -> R ()) -> R Bool
withPoppedComment forall {e}. GenLocated RealSrcSpan e -> Bool
p forall a b. (a -> b) -> a -> b
$ \RealSrcSpan
l Comment
comment -> do
[RealSrcSpan]
lineSpans <- R [RealSrcSpan]
thisLineSpans
let thisCommentLine :: Int
thisCommentLine = RealSrcLoc -> Int
srcLocLine (RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
l)
needsNewline :: Bool
needsNewline =
case forall a. [a] -> Maybe a
listToMaybe [RealSrcSpan]
lineSpans of
Maybe RealSrcSpan
Nothing -> Bool
False
Just RealSrcSpan
spn -> RealSrcLoc -> Int
srcLocLine (RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
spn) forall a. Eq a => a -> a -> Bool
/= Int
thisCommentLine
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
needsNewline Bool -> Bool -> Bool
|| RealSrcSpan -> Maybe SpanMark -> Bool
needsNewlineBefore RealSrcSpan
l Maybe SpanMark
mlastMark) R ()
newline
RealSrcSpan -> Comment -> R ()
spitCommentNow RealSrcSpan
l Comment
comment
if RealSrcSpan -> RealSrcSpan -> Bool
theSameLinePre RealSrcSpan
l RealSrcSpan
ref
then R ()
space
else R ()
newline
spitFollowingComment ::
RealSrcSpan ->
R Bool
RealSrcSpan
ref = do
Maybe SpanMark
mlastMark <- R (Maybe SpanMark)
getSpanMark
Maybe RealSrcSpan
mnSpn <- R (Maybe RealSrcSpan)
nextEltSpan
Maybe RealSrcSpan
meSpn <- (RealSrcSpan -> Bool) -> R (Maybe RealSrcSpan)
getEnclosingSpan (forall a. Eq a => a -> a -> Bool
/= RealSrcSpan
ref)
(RealLocated Comment -> Bool)
-> (RealSrcSpan -> Comment -> R ()) -> R Bool
withPoppedComment (RealSrcSpan
-> Maybe RealSrcSpan
-> Maybe RealSrcSpan
-> Maybe SpanMark
-> RealLocated Comment
-> Bool
commentFollowsElt RealSrcSpan
ref Maybe RealSrcSpan
mnSpn Maybe RealSrcSpan
meSpn Maybe SpanMark
mlastMark) forall a b. (a -> b) -> a -> b
$ \RealSrcSpan
l Comment
comment ->
if RealSrcSpan -> RealSrcSpan -> Bool
theSameLinePost RealSrcSpan
l RealSrcSpan
ref
then
if Comment -> Bool
isMultilineComment Comment
comment
then R ()
space forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RealSrcSpan -> Comment -> R ()
spitCommentNow RealSrcSpan
l Comment
comment
else CommentPosition -> RealSrcSpan -> Comment -> R ()
spitCommentPending CommentPosition
OnTheSameLine RealSrcSpan
l Comment
comment
else do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RealSrcSpan -> Maybe SpanMark -> Bool
needsNewlineBefore RealSrcSpan
l Maybe SpanMark
mlastMark) forall a b. (a -> b) -> a -> b
$
CommentPosition -> Text -> R ()
registerPendingCommentLine CommentPosition
OnNextLine Text
""
CommentPosition -> RealSrcSpan -> Comment -> R ()
spitCommentPending CommentPosition
OnNextLine RealSrcSpan
l Comment
comment
spitRemainingComment ::
R Bool
spitRemainingComment :: R Bool
spitRemainingComment = do
Maybe SpanMark
mlastMark <- R (Maybe SpanMark)
getSpanMark
(RealLocated Comment -> Bool)
-> (RealSrcSpan -> Comment -> R ()) -> R Bool
withPoppedComment (forall a b. a -> b -> a
const Bool
True) forall a b. (a -> b) -> a -> b
$ \RealSrcSpan
l Comment
comment -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RealSrcSpan -> Maybe SpanMark -> Bool
needsNewlineBefore RealSrcSpan
l Maybe SpanMark
mlastMark) R ()
newline
RealSrcSpan -> Comment -> R ()
spitCommentNow RealSrcSpan
l Comment
comment
R ()
newline
handleCommentSeries ::
R Bool ->
R Bool
handleCommentSeries :: R Bool -> R Bool
handleCommentSeries R Bool
f = Bool -> R Bool
go Bool
False
where
go :: Bool -> R Bool
go Bool
gotSome = do
Bool
done <- R Bool
f
if Bool
done
then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
gotSome
else Bool -> R Bool
go Bool
True
withPoppedComment ::
(RealLocated Comment -> Bool) ->
(RealSrcSpan -> Comment -> R ()) ->
R Bool
RealLocated Comment -> Bool
p RealSrcSpan -> Comment -> R ()
f = do
Maybe (RealLocated Comment)
r <- (RealLocated Comment -> Bool) -> R (Maybe (RealLocated Comment))
popComment RealLocated Comment -> Bool
p
case Maybe (RealLocated Comment)
r of
Maybe (RealLocated Comment)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Just (L RealSrcSpan
l Comment
comment) -> Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ RealSrcSpan -> Comment -> R ()
f RealSrcSpan
l Comment
comment
needsNewlineBefore ::
RealSrcSpan ->
Maybe SpanMark ->
Bool
needsNewlineBefore :: RealSrcSpan -> Maybe SpanMark -> Bool
needsNewlineBefore RealSrcSpan
_ (Just (HaddockSpan HaddockStyle
_ RealSrcSpan
_)) = Bool
True
needsNewlineBefore RealSrcSpan
l Maybe SpanMark
mlastMark =
case SpanMark -> RealSrcSpan
spanMarkSpan forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SpanMark
mlastMark of
Maybe RealSrcSpan
Nothing -> Bool
False
Just RealSrcSpan
lastMark ->
RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
l forall a. Ord a => a -> a -> Bool
> RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
lastMark forall a. Num a => a -> a -> a
+ Int
1
theSameLinePre ::
RealSrcSpan ->
RealSrcSpan ->
Bool
theSameLinePre :: RealSrcSpan -> RealSrcSpan -> Bool
theSameLinePre RealSrcSpan
l RealSrcSpan
ref =
RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
l forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
ref
theSameLinePost ::
RealSrcSpan ->
RealSrcSpan ->
Bool
theSameLinePost :: RealSrcSpan -> RealSrcSpan -> Bool
theSameLinePost RealSrcSpan
l RealSrcSpan
ref =
RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
l forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
ref
commentFollowsElt ::
RealSrcSpan ->
Maybe RealSrcSpan ->
Maybe RealSrcSpan ->
Maybe SpanMark ->
RealLocated Comment ->
Bool
RealSrcSpan
ref Maybe RealSrcSpan
mnSpn Maybe RealSrcSpan
meSpn Maybe SpanMark
mlastMark (L RealSrcSpan
l Comment
comment) =
Bool
goesAfter
Bool -> Bool -> Bool
&& Bool
logicallyFollows
Bool -> Bool -> Bool
&& Bool
noEltBetween
Bool -> Bool -> Bool
&& (Bool
continuation Bool -> Bool -> Bool
|| Bool
lastInEnclosing Bool -> Bool -> Bool
|| Bool
supersedesParentElt)
where
goesAfter :: Bool
goesAfter =
RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
l forall a. Ord a => a -> a -> Bool
>= RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
ref
logicallyFollows :: Bool
logicallyFollows =
RealSrcSpan -> RealSrcSpan -> Bool
theSameLinePost RealSrcSpan
l RealSrcSpan
ref
Bool -> Bool -> Bool
|| Bool
continuation
Bool -> Bool -> Bool
|| Bool
lastInEnclosing
noEltBetween :: Bool
noEltBetween =
case Maybe RealSrcSpan
mnSpn of
Maybe RealSrcSpan
Nothing -> Bool
True
Just RealSrcSpan
nspn ->
RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
nspn forall a. Ord a => a -> a -> Bool
>= RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
l
supersedesParentElt :: Bool
supersedesParentElt =
case Maybe RealSrcSpan
meSpn of
Maybe RealSrcSpan
Nothing -> Bool
True
Just RealSrcSpan
espn ->
let startColumn :: RealSrcSpan -> Int
startColumn = RealSrcLoc -> Int
srcLocCol forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> RealSrcLoc
realSrcSpanStart
in RealSrcSpan -> Int
startColumn RealSrcSpan
espn forall a. Ord a => a -> a -> Bool
> RealSrcSpan -> Int
startColumn RealSrcSpan
ref
Bool -> Bool -> Bool
|| ( forall a. Num a => a -> a
abs (RealSrcSpan -> Int
startColumn RealSrcSpan
espn forall a. Num a => a -> a -> a
- RealSrcSpan -> Int
startColumn RealSrcSpan
l)
forall a. Ord a => a -> a -> Bool
>= forall a. Num a => a -> a
abs (RealSrcSpan -> Int
startColumn RealSrcSpan
ref forall a. Num a => a -> a -> a
- RealSrcSpan -> Int
startColumn RealSrcSpan
l)
)
continuation :: Bool
continuation =
Bool -> Bool
not (Comment -> Bool
hasAtomsBefore Comment
comment)
Bool -> Bool -> Bool
&& ( case Maybe SpanMark
mlastMark of
Just (HaddockSpan HaddockStyle
_ RealSrcSpan
_) -> Bool
False
Just (CommentSpan RealSrcSpan
spn) ->
RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
spn forall a. Num a => a -> a -> a
+ Int
1 forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
l
Maybe SpanMark
_ -> Bool
False
)
lastInEnclosing :: Bool
lastInEnclosing =
case Maybe RealSrcSpan
meSpn of
Maybe RealSrcSpan
Nothing -> Bool
False
Just RealSrcSpan
espn ->
let
insideParent :: Bool
insideParent = RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
l forall a. Ord a => a -> a -> Bool
<= RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
espn
nextOutsideParent :: Bool
nextOutsideParent = case Maybe RealSrcSpan
mnSpn of
Maybe RealSrcSpan
Nothing -> Bool
True
Just RealSrcSpan
nspn -> RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
espn forall a. Ord a => a -> a -> Bool
< RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
nspn
in Bool
insideParent Bool -> Bool -> Bool
&& Bool
nextOutsideParent
spitCommentNow :: RealSrcSpan -> Comment -> R ()
RealSrcSpan
spn Comment
comment = do
R () -> R ()
sitcc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> NonEmpty a -> NonEmpty a
NE.intersperse R ()
newline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> R ()
txt forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Comment -> NonEmpty String
unComment
forall a b. (a -> b) -> a -> b
$ Comment
comment
SpanMark -> R ()
setSpanMark (RealSrcSpan -> SpanMark
CommentSpan RealSrcSpan
spn)
spitCommentPending :: CommentPosition -> RealSrcSpan -> Comment -> R ()
CommentPosition
position RealSrcSpan
spn Comment
comment = do
let wrapper :: R () -> R ()
wrapper = case CommentPosition
position of
CommentPosition
OnTheSameLine -> R () -> R ()
sitcc
CommentPosition
OnNextLine -> forall a. a -> a
id
R () -> R ()
wrapper
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NE.toList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CommentPosition -> Text -> R ()
registerPendingCommentLine CommentPosition
position forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Comment -> NonEmpty String
unComment
forall a b. (a -> b) -> a -> b
$ Comment
comment
SpanMark -> R ()
setSpanMark (RealSrcSpan -> SpanMark
CommentSpan RealSrcSpan
spn)