{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

-- | In most cases import "Ormolu.Printer.Combinators" instead, these
-- functions are the low-level building blocks and should not be used on
-- their own. The 'R' monad is re-exported from "Ormolu.Printer.Combinators"
-- as well.
module Ormolu.Printer.Internal
  ( -- * The 'R' monad
    R,
    runR,

    -- * Internal functions
    txt,
    interferingTxt,
    atom,
    space,
    newline,
    declNewline,
    useRecordDot,
    inci,
    inciBy,
    sitcc,
    Layout (..),
    enterLayout,
    vlayout,
    getLayout,
    getPrinterOpt,

    -- * Helpers for braces
    useBraces,
    dontUseBraces,
    canUseBraces,

    -- * Special helpers for comment placement
    CommentPosition (..),
    registerPendingCommentLine,
    trimSpanStream,
    nextEltSpan,
    popComment,
    getEnclosingSpan,
    withEnclosingSpan,
    thisLineSpans,

    -- * Stateful markers
    SpanMark (..),
    spanMarkSpan,
    HaddockStyle (..),
    setSpanMark,
    getSpanMark,

    -- * Annotations
    getAnns,
  )
where

import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Bool (bool)
import Data.Coerce
import Data.Functor.Identity (runIdentity)
import Data.Maybe (listToMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Builder
import GHC
import Ormolu.Config
import Ormolu.Parser.Anns
import Ormolu.Parser.CommentStream
import Ormolu.Printer.SpanStream
import Ormolu.Utils (showOutputable)
import Outputable (Outputable)

----------------------------------------------------------------------------
-- The 'R' monad

-- | The 'R' monad hosts combinators that allow us to describe how to render
-- AST.
newtype R a = R (ReaderT RC (State SC) a)
  deriving (a -> R b -> R a
(a -> b) -> R a -> R b
(forall a b. (a -> b) -> R a -> R b)
-> (forall a b. a -> R b -> R a) -> Functor R
forall a b. a -> R b -> R a
forall a b. (a -> b) -> R a -> R b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> R b -> R a
$c<$ :: forall a b. a -> R b -> R a
fmap :: (a -> b) -> R a -> R b
$cfmap :: forall a b. (a -> b) -> R a -> R b
Functor, Functor R
a -> R a
Functor R
-> (forall a. a -> R a)
-> (forall a b. R (a -> b) -> R a -> R b)
-> (forall a b c. (a -> b -> c) -> R a -> R b -> R c)
-> (forall a b. R a -> R b -> R b)
-> (forall a b. R a -> R b -> R a)
-> Applicative R
R a -> R b -> R b
R a -> R b -> R a
R (a -> b) -> R a -> R b
(a -> b -> c) -> R a -> R b -> R c
forall a. a -> R a
forall a b. R a -> R b -> R a
forall a b. R a -> R b -> R b
forall a b. R (a -> b) -> R a -> R b
forall a b c. (a -> b -> c) -> R a -> R b -> R c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: R a -> R b -> R a
$c<* :: forall a b. R a -> R b -> R a
*> :: R a -> R b -> R b
$c*> :: forall a b. R a -> R b -> R b
liftA2 :: (a -> b -> c) -> R a -> R b -> R c
$cliftA2 :: forall a b c. (a -> b -> c) -> R a -> R b -> R c
<*> :: R (a -> b) -> R a -> R b
$c<*> :: forall a b. R (a -> b) -> R a -> R b
pure :: a -> R a
$cpure :: forall a. a -> R a
$cp1Applicative :: Functor R
Applicative, Applicative R
a -> R a
Applicative R
-> (forall a b. R a -> (a -> R b) -> R b)
-> (forall a b. R a -> R b -> R b)
-> (forall a. a -> R a)
-> Monad R
R a -> (a -> R b) -> R b
R a -> R b -> R b
forall a. a -> R a
forall a b. R a -> R b -> R b
forall a b. R a -> (a -> R b) -> R b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> R a
$creturn :: forall a. a -> R a
>> :: R a -> R b -> R b
$c>> :: forall a b. R a -> R b -> R b
>>= :: R a -> (a -> R b) -> R b
$c>>= :: forall a b. R a -> (a -> R b) -> R b
$cp1Monad :: Applicative R
Monad)

-- | Reader context of 'R'. This should be used when we control rendering by
-- enclosing certain expressions with wrappers.
data RC = RC
  { -- | Indentation level, as the column index we need to start from after
    -- a newline if we break lines
    RC -> Int
rcIndent :: !Int,
    -- | Current layout
    RC -> Layout
rcLayout :: Layout,
    -- | Spans of enclosing elements of AST
    RC -> [RealSrcSpan]
rcEnclosingSpans :: [RealSrcSpan],
    -- | Collection of annotations
    RC -> Anns
rcAnns :: Anns,
    -- | Whether the last expression in the layout can use braces
    RC -> Bool
rcCanUseBraces :: Bool,
    -- | Whether the source could have used the record dot preprocessor
    RC -> Bool
rcUseRecDot :: Bool,
    RC -> PrinterOptsTotal
rcPrinterOpts :: PrinterOptsTotal
  }

-- | State context of 'R'.
data SC = SC
  { -- | Index of the next column to render
    SC -> Int
scColumn :: !Int,
    -- | Indentation level that was used for the current line
    SC -> Int
scIndent :: !Int,
    -- | Rendered source code so far
    SC -> Builder
scBuilder :: Builder,
    -- | Span stream
    SC -> SpanStream
scSpanStream :: SpanStream,
    -- | Spans of atoms that have been printed on the current line so far
    SC -> [RealSrcSpan]
scThisLineSpans :: [RealSrcSpan],
    -- | Comment stream
    SC -> CommentStream
scCommentStream :: CommentStream,
    -- | Pending comment lines (in reverse order) to be inserted before next
    -- newline, 'Int' is the indentation level
    SC -> [(CommentPosition, Text)]
scPendingComments :: ![(CommentPosition, Text)],
    -- | Whether to output a space before the next output
    SC -> RequestedDelimiter
scRequestedDelimiter :: !RequestedDelimiter,
    -- | An auxiliary marker for keeping track of last output element
    SC -> Maybe SpanMark
scSpanMark :: !(Maybe SpanMark)
  }

-- | Make sure next output is delimited by one of the following.
data RequestedDelimiter
  = -- | A space
    RequestedSpace
  | -- | A newline
    RequestedNewline
  | -- | Nothing
    RequestedNothing
  | -- | We just output a newline
    AfterNewline
  | -- | We haven't printed anything yet
    VeryBeginning
  deriving (RequestedDelimiter -> RequestedDelimiter -> Bool
(RequestedDelimiter -> RequestedDelimiter -> Bool)
-> (RequestedDelimiter -> RequestedDelimiter -> Bool)
-> Eq RequestedDelimiter
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RequestedDelimiter -> RequestedDelimiter -> Bool
$c/= :: RequestedDelimiter -> RequestedDelimiter -> Bool
== :: RequestedDelimiter -> RequestedDelimiter -> Bool
$c== :: RequestedDelimiter -> RequestedDelimiter -> Bool
Eq, Int -> RequestedDelimiter -> ShowS
[RequestedDelimiter] -> ShowS
RequestedDelimiter -> String
(Int -> RequestedDelimiter -> ShowS)
-> (RequestedDelimiter -> String)
-> ([RequestedDelimiter] -> ShowS)
-> Show RequestedDelimiter
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RequestedDelimiter] -> ShowS
$cshowList :: [RequestedDelimiter] -> ShowS
show :: RequestedDelimiter -> String
$cshow :: RequestedDelimiter -> String
showsPrec :: Int -> RequestedDelimiter -> ShowS
$cshowsPrec :: Int -> RequestedDelimiter -> ShowS
Show)

-- | 'Layout' options.
data Layout
  = -- | Put everything on single line
    SingleLine
  | -- | Use multiple lines
    MultiLine
  deriving (Layout -> Layout -> Bool
(Layout -> Layout -> Bool)
-> (Layout -> Layout -> Bool) -> Eq Layout
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Layout -> Layout -> Bool
$c/= :: Layout -> Layout -> Bool
== :: Layout -> Layout -> Bool
$c== :: Layout -> Layout -> Bool
Eq, Int -> Layout -> ShowS
[Layout] -> ShowS
Layout -> String
(Int -> Layout -> ShowS)
-> (Layout -> String) -> ([Layout] -> ShowS) -> Show Layout
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Layout] -> ShowS
$cshowList :: [Layout] -> ShowS
show :: Layout -> String
$cshow :: Layout -> String
showsPrec :: Int -> Layout -> ShowS
$cshowsPrec :: Int -> Layout -> ShowS
Show)

-- | Modes for rendering of pending comments.
data CommentPosition
  = -- | Put the comment on the same line
    OnTheSameLine
  | -- | Put the comment on next line
    OnNextLine
  deriving (CommentPosition -> CommentPosition -> Bool
(CommentPosition -> CommentPosition -> Bool)
-> (CommentPosition -> CommentPosition -> Bool)
-> Eq CommentPosition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommentPosition -> CommentPosition -> Bool
$c/= :: CommentPosition -> CommentPosition -> Bool
== :: CommentPosition -> CommentPosition -> Bool
$c== :: CommentPosition -> CommentPosition -> Bool
Eq, Int -> CommentPosition -> ShowS
[CommentPosition] -> ShowS
CommentPosition -> String
(Int -> CommentPosition -> ShowS)
-> (CommentPosition -> String)
-> ([CommentPosition] -> ShowS)
-> Show CommentPosition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CommentPosition] -> ShowS
$cshowList :: [CommentPosition] -> ShowS
show :: CommentPosition -> String
$cshow :: CommentPosition -> String
showsPrec :: Int -> CommentPosition -> ShowS
$cshowsPrec :: Int -> CommentPosition -> ShowS
Show)

-- | Run an 'R' monad.
runR ::
  -- | Monad to run
  R () ->
  -- | Span stream
  SpanStream ->
  -- | Comment stream
  CommentStream ->
  -- | Annotations
  Anns ->
  PrinterOptsTotal ->
  -- | Use Record Dot Syntax
  Bool ->
  -- | Resulting rendition
  Text
runR :: R ()
-> SpanStream
-> CommentStream
-> Anns
-> PrinterOptsTotal
-> Bool
-> Text
runR (R ReaderT RC (State SC) ()
m) SpanStream
sstream CommentStream
cstream Anns
anns PrinterOptsTotal
printerOpts Bool
recDot =
  Text -> Text
TL.toStrict (Text -> Text) -> (SC -> Text) -> SC -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText (Builder -> Text) -> (SC -> Builder) -> SC -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SC -> Builder
scBuilder (SC -> Text) -> SC -> Text
forall a b. (a -> b) -> a -> b
$ State SC () -> SC -> SC
forall s a. State s a -> s -> s
execState (ReaderT RC (State SC) () -> RC -> State SC ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT RC (State SC) ()
m RC
rc) SC
sc
  where
    rc :: RC
rc =
      RC :: Int
-> Layout
-> [RealSrcSpan]
-> Anns
-> Bool
-> Bool
-> PrinterOptsTotal
-> RC
RC
        { rcIndent :: Int
rcIndent = Int
0,
          rcLayout :: Layout
rcLayout = Layout
MultiLine,
          rcEnclosingSpans :: [RealSrcSpan]
rcEnclosingSpans = [],
          rcAnns :: Anns
rcAnns = Anns
anns,
          rcCanUseBraces :: Bool
rcCanUseBraces = Bool
False,
          rcUseRecDot :: Bool
rcUseRecDot = Bool
recDot,
          rcPrinterOpts :: PrinterOptsTotal
rcPrinterOpts = PrinterOptsTotal
printerOpts
        }
    sc :: SC
sc =
      SC :: Int
-> Int
-> Builder
-> SpanStream
-> [RealSrcSpan]
-> CommentStream
-> [(CommentPosition, Text)]
-> RequestedDelimiter
-> Maybe SpanMark
-> SC
SC
        { scColumn :: Int
scColumn = Int
0,
          scIndent :: Int
scIndent = Int
0,
          scBuilder :: Builder
scBuilder = Builder
forall a. Monoid a => a
mempty,
          scSpanStream :: SpanStream
scSpanStream = SpanStream
sstream,
          scThisLineSpans :: [RealSrcSpan]
scThisLineSpans = [],
          scCommentStream :: CommentStream
scCommentStream = CommentStream
cstream,
          scPendingComments :: [(CommentPosition, Text)]
scPendingComments = [],
          scRequestedDelimiter :: RequestedDelimiter
scRequestedDelimiter = RequestedDelimiter
VeryBeginning,
          scSpanMark :: Maybe SpanMark
scSpanMark = Maybe SpanMark
forall a. Maybe a
Nothing
        }

----------------------------------------------------------------------------
-- Internal functions

-- | Type of the thing to output. Influences the primary low-level rendering
-- function 'spit'.
data SpitType
  = -- | Simple opaque text that breaks comment series.
    SimpleText
  | -- | Like 'SimpleText', but assume that when this text is inserted it
    -- will separate an 'Atom' and its pending comments, so insert an extra
    -- 'newline' in that case to force the pending comments and continue on
    -- a fresh line.
    InterferingText
  | -- | An atom that typically have span information in the AST and can
    -- have comments attached to it.
    Atom
  | -- | Used for rendering comment lines.
    CommentPart
  deriving (Int -> SpitType -> ShowS
[SpitType] -> ShowS
SpitType -> String
(Int -> SpitType -> ShowS)
-> (SpitType -> String) -> ([SpitType] -> ShowS) -> Show SpitType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SpitType] -> ShowS
$cshowList :: [SpitType] -> ShowS
show :: SpitType -> String
$cshow :: SpitType -> String
showsPrec :: Int -> SpitType -> ShowS
$cshowsPrec :: Int -> SpitType -> ShowS
Show, SpitType -> SpitType -> Bool
(SpitType -> SpitType -> Bool)
-> (SpitType -> SpitType -> Bool) -> Eq SpitType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SpitType -> SpitType -> Bool
$c/= :: SpitType -> SpitType -> Bool
== :: SpitType -> SpitType -> Bool
$c== :: SpitType -> SpitType -> Bool
Eq)

-- | Output a fixed 'Text' fragment. The argument may not contain any line
-- breaks. 'txt' is used to output all sorts of “fixed” bits of syntax like
-- keywords and pipes @|@ in functional dependencies.
--
-- To separate various bits of syntax with white space use 'space' instead
-- of @'txt' " "@. To output 'Outputable' Haskell entities like numbers use
-- 'atom'.
txt ::
  -- | 'Text' to output
  Text ->
  R ()
txt :: Text -> R ()
txt = SpitType -> Text -> R ()
spit SpitType
SimpleText

-- | Similar to 'txt' but the text inserted this way is assumed to break the
-- “link” between the preceding atom and its pending comments.
interferingTxt ::
  -- | 'Text' to output
  Text ->
  R ()
interferingTxt :: Text -> R ()
interferingTxt = SpitType -> Text -> R ()
spit SpitType
InterferingText

-- | Output 'Outputable' fragment of AST. This can be used to output numeric
-- literals and similar. Everything that doesn't have inner structure but
-- does have an 'Outputable' instance.
atom ::
  Outputable a =>
  a ->
  R ()
atom :: a -> R ()
atom = SpitType -> Text -> R ()
spit SpitType
Atom (Text -> R ()) -> (a -> Text) -> a -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall o. Outputable o => o -> String
showOutputable

-- | Low-level non-public helper to define 'txt' and 'atom'.
spit ::
  -- | Type of the thing to spit
  SpitType ->
  -- | 'Text' to output
  Text ->
  R ()
spit :: SpitType -> Text -> R ()
spit SpitType
_ Text
"" = () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
spit SpitType
stype Text
text = do
  RequestedDelimiter
requestedDel <- ReaderT RC (State SC) RequestedDelimiter -> R RequestedDelimiter
forall a. ReaderT RC (State SC) a -> R a
R ((SC -> RequestedDelimiter)
-> ReaderT RC (State SC) RequestedDelimiter
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SC -> RequestedDelimiter
scRequestedDelimiter)
  [(CommentPosition, Text)]
pendingComments <- ReaderT RC (State SC) [(CommentPosition, Text)]
-> R [(CommentPosition, Text)]
forall a. ReaderT RC (State SC) a -> R a
R ((SC -> [(CommentPosition, Text)])
-> ReaderT RC (State SC) [(CommentPosition, Text)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SC -> [(CommentPosition, Text)]
scPendingComments)
  Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SpitType
stype SpitType -> SpitType -> Bool
forall a. Eq a => a -> a -> Bool
== SpitType
InterferingText Bool -> Bool -> Bool
&& Bool -> Bool
not ([(CommentPosition, Text)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(CommentPosition, Text)]
pendingComments)) R ()
newline
  case RequestedDelimiter
requestedDel of
    RequestedDelimiter
RequestedNewline -> do
      ReaderT RC (State SC) () -> R ()
forall a. ReaderT RC (State SC) a -> R a
R (ReaderT RC (State SC) () -> R ())
-> ((SC -> SC) -> ReaderT RC (State SC) ()) -> (SC -> SC) -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SC -> SC) -> ReaderT RC (State SC) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((SC -> SC) -> R ()) -> (SC -> SC) -> R ()
forall a b. (a -> b) -> a -> b
$ \SC
sc ->
        SC
sc
          { scRequestedDelimiter :: RequestedDelimiter
scRequestedDelimiter = RequestedDelimiter
RequestedNothing
          }
      case SpitType
stype of
        SpitType
CommentPart -> R ()
newlineRaw
        SpitType
_ -> R ()
newline
    RequestedDelimiter
_ -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  ReaderT RC (State SC) () -> R ()
forall a. ReaderT RC (State SC) a -> R a
R (ReaderT RC (State SC) () -> R ())
-> ReaderT RC (State SC) () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    Int
i <- (RC -> Int) -> ReaderT RC (State SC) Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RC -> Int
rcIndent
    Int
c <- (SC -> Int) -> ReaderT RC (State SC) Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SC -> Int
scColumn
    Maybe RealSrcSpan
closestEnclosing <- [RealSrcSpan] -> Maybe RealSrcSpan
forall a. [a] -> Maybe a
listToMaybe ([RealSrcSpan] -> Maybe RealSrcSpan)
-> ReaderT RC (State SC) [RealSrcSpan]
-> ReaderT RC (State SC) (Maybe RealSrcSpan)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RC -> [RealSrcSpan]) -> ReaderT RC (State SC) [RealSrcSpan]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RC -> [RealSrcSpan]
rcEnclosingSpans
    let indentedTxt :: Text
indentedTxt = Text
spaces Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text
        spaces :: Text
spaces = Int -> Text -> Text
T.replicate Int
spacesN Text
" "
        spacesN :: Int
spacesN =
          if Int
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
            then Int
i
            else Int -> Int -> Bool -> Int
forall a. a -> a -> Bool -> a
bool Int
0 Int
1 (RequestedDelimiter
requestedDel RequestedDelimiter -> RequestedDelimiter -> Bool
forall a. Eq a => a -> a -> Bool
== RequestedDelimiter
RequestedSpace)
    (SC -> SC) -> ReaderT RC (State SC) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((SC -> SC) -> ReaderT RC (State SC) ())
-> (SC -> SC) -> ReaderT RC (State SC) ()
forall a b. (a -> b) -> a -> b
$ \SC
sc ->
      SC
sc
        { scBuilder :: Builder
scBuilder = SC -> Builder
scBuilder SC
sc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
indentedTxt,
          scColumn :: Int
scColumn = SC -> Int
scColumn SC
sc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
T.length Text
indentedTxt,
          scIndent :: Int
scIndent =
            if Int
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
              then Int
i
              else SC -> Int
scIndent SC
sc,
          scThisLineSpans :: [RealSrcSpan]
scThisLineSpans =
            let xs :: [RealSrcSpan]
xs = SC -> [RealSrcSpan]
scThisLineSpans SC
sc
             in case SpitType
stype of
                  SpitType
Atom -> case Maybe RealSrcSpan
closestEnclosing of
                    Maybe RealSrcSpan
Nothing -> [RealSrcSpan]
xs
                    Just RealSrcSpan
x -> RealSrcSpan
x RealSrcSpan -> [RealSrcSpan] -> [RealSrcSpan]
forall a. a -> [a] -> [a]
: [RealSrcSpan]
xs
                  SpitType
_ -> [RealSrcSpan]
xs,
          scRequestedDelimiter :: RequestedDelimiter
scRequestedDelimiter = RequestedDelimiter
RequestedNothing,
          scSpanMark :: Maybe SpanMark
scSpanMark =
            -- If there are pending comments, do not reset last comment
            -- location.
            if (SpitType
stype SpitType -> SpitType -> Bool
forall a. Eq a => a -> a -> Bool
== SpitType
CommentPart) Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool) -> (SC -> Bool) -> SC -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(CommentPosition, Text)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(CommentPosition, Text)] -> Bool)
-> (SC -> [(CommentPosition, Text)]) -> SC -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SC -> [(CommentPosition, Text)]
scPendingComments) SC
sc
              then SC -> Maybe SpanMark
scSpanMark SC
sc
              else Maybe SpanMark
forall a. Maybe a
Nothing
        }

-- | This primitive /does not/ necessarily output a space. It just ensures
-- that the next thing that will be printed on the same line will be
-- separated by a single space from the previous output. Using this
-- combinator twice results in at most one space.
--
-- In practice this design prevents trailing white space and makes it hard
-- to output more than one delimiting space in a row, which is what we
-- usually want.
space :: R ()
space :: R ()
space = ReaderT RC (State SC) () -> R ()
forall a. ReaderT RC (State SC) a -> R a
R (ReaderT RC (State SC) () -> R ())
-> ((SC -> SC) -> ReaderT RC (State SC) ()) -> (SC -> SC) -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SC -> SC) -> ReaderT RC (State SC) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((SC -> SC) -> R ()) -> (SC -> SC) -> R ()
forall a b. (a -> b) -> a -> b
$ \SC
sc ->
  SC
sc
    { scRequestedDelimiter :: RequestedDelimiter
scRequestedDelimiter = case SC -> RequestedDelimiter
scRequestedDelimiter SC
sc of
        RequestedDelimiter
RequestedNothing -> RequestedDelimiter
RequestedSpace
        RequestedDelimiter
other -> RequestedDelimiter
other
    }

declNewline :: R ()
declNewline :: R ()
declNewline = Int -> R ()
newlineRawN (Int -> R ()) -> R Int -> R ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall (f :: * -> *). PrinterOpts f -> f Int) -> R Int
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f Int
poNewlinesBetweenDecls

-- | Output a newline. First time 'newline' is used after some non-'newline'
-- output it gets inserted immediately. Second use of 'newline' does not
-- output anything but makes sure that the next non-white space output will
-- be prefixed by a newline. Using 'newline' more than twice in a row has no
-- effect. Also, using 'newline' at the very beginning has no effect, this
-- is to avoid leading whitespace.
--
-- Similarly to 'space', this design prevents trailing newlines and makes it
-- hard to output more than one blank newline in a row.
newline :: R ()
newline :: R ()
newline = do
  Int
indent <- ReaderT RC (State SC) Int -> R Int
forall a. ReaderT RC (State SC) a -> R a
R ((SC -> Int) -> ReaderT RC (State SC) Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SC -> Int
scIndent)
  [(CommentPosition, Text)]
cs <- [(CommentPosition, Text)] -> [(CommentPosition, Text)]
forall a. [a] -> [a]
reverse ([(CommentPosition, Text)] -> [(CommentPosition, Text)])
-> R [(CommentPosition, Text)] -> R [(CommentPosition, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT RC (State SC) [(CommentPosition, Text)]
-> R [(CommentPosition, Text)]
forall a. ReaderT RC (State SC) a -> R a
R ((SC -> [(CommentPosition, Text)])
-> ReaderT RC (State SC) [(CommentPosition, Text)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SC -> [(CommentPosition, Text)]
scPendingComments)
  case [(CommentPosition, Text)]
cs of
    [] -> R ()
newlineRaw
    ((CommentPosition
position, Text
_) : [(CommentPosition, Text)]
_) -> do
      case CommentPosition
position of
        CommentPosition
OnTheSameLine -> R ()
space
        CommentPosition
OnNextLine -> R ()
newlineRaw
      ReaderT RC (State SC) () -> R ()
forall a. ReaderT RC (State SC) a -> R a
R (ReaderT RC (State SC) () -> R ())
-> (((CommentPosition, Text) -> ReaderT RC (State SC) ())
    -> ReaderT RC (State SC) ())
-> ((CommentPosition, Text) -> ReaderT RC (State SC) ())
-> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(CommentPosition, Text)]
-> ((CommentPosition, Text) -> ReaderT RC (State SC) ())
-> ReaderT RC (State SC) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(CommentPosition, Text)]
cs (((CommentPosition, Text) -> ReaderT RC (State SC) ()) -> R ())
-> ((CommentPosition, Text) -> ReaderT RC (State SC) ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \(CommentPosition
_, Text
text) ->
        let modRC :: RC -> RC
modRC RC
rc =
              RC
rc
                { rcIndent :: Int
rcIndent = Int
indent
                }
            R ReaderT RC (State SC) ()
m = do
              Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
text) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
                SpitType -> Text -> R ()
spit SpitType
CommentPart Text
text
              R ()
newlineRaw
         in (RC -> RC) -> ReaderT RC (State SC) () -> ReaderT RC (State SC) ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local RC -> RC
modRC ReaderT RC (State SC) ()
m
      ReaderT RC (State SC) () -> R ()
forall a. ReaderT RC (State SC) a -> R a
R (ReaderT RC (State SC) () -> R ())
-> ((SC -> SC) -> ReaderT RC (State SC) ()) -> (SC -> SC) -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SC -> SC) -> ReaderT RC (State SC) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((SC -> SC) -> R ()) -> (SC -> SC) -> R ()
forall a b. (a -> b) -> a -> b
$ \SC
sc ->
        SC
sc
          { scPendingComments :: [(CommentPosition, Text)]
scPendingComments = []
          }

-- | Low-level newline primitive. This one always just inserts a newline, no
-- hooks can be attached.
newlineRaw :: R ()
newlineRaw :: R ()
newlineRaw = Int -> R ()
newlineRawN Int
1

-- | Low-level newline primitive. This always inserts 'n' newlines.
newlineRawN :: Int -> R ()
newlineRawN :: Int -> R ()
newlineRawN Int
n = ReaderT RC (State SC) () -> R ()
forall a. ReaderT RC (State SC) a -> R a
R (ReaderT RC (State SC) () -> R ())
-> ((SC -> SC) -> ReaderT RC (State SC) ()) -> (SC -> SC) -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SC -> SC) -> ReaderT RC (State SC) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((SC -> SC) -> R ()) -> (SC -> SC) -> R ()
forall a b. (a -> b) -> a -> b
$ \SC
sc ->
  let requestedDel :: RequestedDelimiter
requestedDel = SC -> RequestedDelimiter
scRequestedDelimiter SC
sc
      builderSoFar :: Builder
builderSoFar = SC -> Builder
scBuilder SC
sc
      n' :: Int
n' = case RequestedDelimiter
requestedDel of
        RequestedDelimiter
AfterNewline -> Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        RequestedDelimiter
RequestedNewline -> Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        RequestedDelimiter
VeryBeginning -> Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        RequestedDelimiter
_ -> Int
n
   in SC
sc
        { scBuilder :: Builder
scBuilder = Builder
builderSoFar Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (Int -> Builder -> [Builder]
forall a. Int -> a -> [a]
replicate Int
n' Builder
"\n"),
          scColumn :: Int
scColumn = Int
0,
          scIndent :: Int
scIndent = Int
0,
          scThisLineSpans :: [RealSrcSpan]
scThisLineSpans = [],
          scRequestedDelimiter :: RequestedDelimiter
scRequestedDelimiter = case SC -> RequestedDelimiter
scRequestedDelimiter SC
sc of
            RequestedDelimiter
AfterNewline -> RequestedDelimiter
RequestedNewline
            RequestedDelimiter
RequestedNewline -> RequestedDelimiter
RequestedNewline
            RequestedDelimiter
VeryBeginning -> RequestedDelimiter
VeryBeginning
            RequestedDelimiter
_ -> RequestedDelimiter
AfterNewline
        }

-- | Return 'True' if we should print record dot syntax.
useRecordDot :: R Bool
useRecordDot :: R Bool
useRecordDot = ReaderT RC (State SC) Bool -> R Bool
forall a. ReaderT RC (State SC) a -> R a
R ((RC -> Bool) -> ReaderT RC (State SC) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RC -> Bool
rcUseRecDot)

-- | Increase indentation level by one indentation step for the inner
-- computation. 'inci' should be used when a part of code must be more
-- indented relative to the parts outside of 'inci' in order for the output
-- to be valid Haskell. When layout is single-line there is no obvious
-- effect, but with multi-line layout correct indentation levels matter.
inci :: R () -> R ()
inci :: R () -> R ()
inci = Int -> R () -> R ()
inciBy Int
1

-- | Like 'inci', but indents by the given fraction of a full step.
inciBy :: Int -> R () -> R ()
inciBy :: Int -> R () -> R ()
inciBy Int
x (R ReaderT RC (State SC) ()
m) = do
  Int
step <- (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
x) (Int -> Int) -> R Int -> R Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT RC (State SC) Int -> R Int
forall a. ReaderT RC (State SC) a -> R a
R ((RC -> Int) -> ReaderT RC (State SC) Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Identity Int -> Int
forall a. Identity a -> a
runIdentity (Identity Int -> Int) -> (RC -> Identity Int) -> RC -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrinterOptsTotal -> Identity Int
forall (f :: * -> *). PrinterOpts f -> f Int
poIndentation (PrinterOptsTotal -> Identity Int)
-> (RC -> PrinterOptsTotal) -> RC -> Identity Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RC -> PrinterOptsTotal
rcPrinterOpts))
  let modRC :: RC -> RC
modRC RC
rc =
        RC
rc
          { rcIndent :: Int
rcIndent = Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundDownToNearest Int
step (RC -> Int
rcIndent RC
rc) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
step
          }
  ReaderT RC (State SC) () -> R ()
forall a. ReaderT RC (State SC) a -> R a
R ((RC -> RC) -> ReaderT RC (State SC) () -> ReaderT RC (State SC) ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local RC -> RC
modRC ReaderT RC (State SC) ()
m)
  where
    roundDownToNearest :: a -> a -> a
roundDownToNearest a
r a
n = (a
n a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
r) a -> a -> a
forall a. Num a => a -> a -> a
* a
r

-- | Set indentation level for the inner computation equal to current
-- column. This makes sure that the entire inner block is uniformly
-- \"shifted\" to the right.
sitcc :: R () -> R ()
sitcc :: R () -> R ()
sitcc (R ReaderT RC (State SC) ()
m) = do
  RequestedDelimiter
requestedDel <- ReaderT RC (State SC) RequestedDelimiter -> R RequestedDelimiter
forall a. ReaderT RC (State SC) a -> R a
R ((SC -> RequestedDelimiter)
-> ReaderT RC (State SC) RequestedDelimiter
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SC -> RequestedDelimiter
scRequestedDelimiter)
  Int
i <- ReaderT RC (State SC) Int -> R Int
forall a. ReaderT RC (State SC) a -> R a
R ((RC -> Int) -> ReaderT RC (State SC) Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RC -> Int
rcIndent)
  Int
c <- ReaderT RC (State SC) Int -> R Int
forall a. ReaderT RC (State SC) a -> R a
R ((SC -> Int) -> ReaderT RC (State SC) Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SC -> Int
scColumn)
  let modRC :: RC -> RC
modRC RC
rc =
        RC
rc
          { rcIndent :: Int
rcIndent = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
i (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Bool -> Int
forall a. a -> a -> Bool -> a
bool Int
0 Int
1 (RequestedDelimiter
requestedDel RequestedDelimiter -> RequestedDelimiter -> Bool
forall a. Eq a => a -> a -> Bool
== RequestedDelimiter
RequestedSpace))
          }
  ReaderT RC (State SC) () -> R ()
forall a. ReaderT RC (State SC) a -> R a
R ((RC -> RC) -> ReaderT RC (State SC) () -> ReaderT RC (State SC) ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local RC -> RC
modRC ReaderT RC (State SC) ()
m)

-- | Set 'Layout' for internal computation.
enterLayout :: Layout -> R () -> R ()
enterLayout :: Layout -> R () -> R ()
enterLayout Layout
l (R ReaderT RC (State SC) ()
m) = ReaderT RC (State SC) () -> R ()
forall a. ReaderT RC (State SC) a -> R a
R ((RC -> RC) -> ReaderT RC (State SC) () -> ReaderT RC (State SC) ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local RC -> RC
modRC ReaderT RC (State SC) ()
m)
  where
    modRC :: RC -> RC
modRC RC
rc =
      RC
rc
        { rcLayout :: Layout
rcLayout = Layout
l
        }

-- | Do one or another thing depending on current 'Layout'.
vlayout ::
  -- | Single line
  R a ->
  -- | Multi line
  R a ->
  R a
vlayout :: R a -> R a -> R a
vlayout R a
sline R a
mline = do
  Layout
l <- R Layout
getLayout
  case Layout
l of
    Layout
SingleLine -> R a
sline
    Layout
MultiLine -> R a
mline

-- | Get current 'Layout'.
getLayout :: R Layout
getLayout :: R Layout
getLayout = ReaderT RC (State SC) Layout -> R Layout
forall a. ReaderT RC (State SC) a -> R a
R ((RC -> Layout) -> ReaderT RC (State SC) Layout
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RC -> Layout
rcLayout)

-- | Get a particular 'PrinterOpts' field from the environment.
getPrinterOpt :: (forall f. PrinterOpts f -> f a) -> R a
getPrinterOpt :: (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f a
f = ReaderT RC (State SC) a -> R a
forall a. ReaderT RC (State SC) a -> R a
R (ReaderT RC (State SC) a -> R a) -> ReaderT RC (State SC) a -> R a
forall a b. (a -> b) -> a -> b
$ (RC -> a) -> ReaderT RC (State SC) a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((RC -> a) -> ReaderT RC (State SC) a)
-> (RC -> a) -> ReaderT RC (State SC) a
forall a b. (a -> b) -> a -> b
$ Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> (RC -> Identity a) -> RC -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrinterOptsTotal -> Identity a
forall (f :: * -> *). PrinterOpts f -> f a
f (PrinterOptsTotal -> Identity a)
-> (RC -> PrinterOptsTotal) -> RC -> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RC -> PrinterOptsTotal
rcPrinterOpts

----------------------------------------------------------------------------
-- Special helpers for comment placement

-- | Register a comment line for outputting. It will be inserted right
-- before next newline. When the comment goes after something else on the
-- same line, a space will be inserted between preceding text and the
-- comment when necessary.
registerPendingCommentLine ::
  -- | Comment position
  CommentPosition ->
  -- | 'Text' to output
  Text ->
  R ()
registerPendingCommentLine :: CommentPosition -> Text -> R ()
registerPendingCommentLine CommentPosition
position Text
text = ReaderT RC (State SC) () -> R ()
forall a. ReaderT RC (State SC) a -> R a
R (ReaderT RC (State SC) () -> R ())
-> ReaderT RC (State SC) () -> R ()
forall a b. (a -> b) -> a -> b
$ do
  (SC -> SC) -> ReaderT RC (State SC) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((SC -> SC) -> ReaderT RC (State SC) ())
-> (SC -> SC) -> ReaderT RC (State SC) ()
forall a b. (a -> b) -> a -> b
$ \SC
sc ->
    SC
sc
      { scPendingComments :: [(CommentPosition, Text)]
scPendingComments = (CommentPosition
position, Text
text) (CommentPosition, Text)
-> [(CommentPosition, Text)] -> [(CommentPosition, Text)]
forall a. a -> [a] -> [a]
: SC -> [(CommentPosition, Text)]
scPendingComments SC
sc
      }

-- | Drop elements that begin before or at the same place as given
-- 'SrcSpan'.
trimSpanStream ::
  -- | Reference span
  RealSrcSpan ->
  R ()
trimSpanStream :: RealSrcSpan -> R ()
trimSpanStream RealSrcSpan
ref = do
  let leRef :: RealSrcSpan -> Bool
      leRef :: RealSrcSpan -> Bool
leRef RealSrcSpan
x = RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
x RealSrcLoc -> RealSrcLoc -> Bool
forall a. Ord a => a -> a -> Bool
<= RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
ref
  ReaderT RC (State SC) () -> R ()
forall a. ReaderT RC (State SC) a -> R a
R (ReaderT RC (State SC) () -> R ())
-> ((SC -> SC) -> ReaderT RC (State SC) ()) -> (SC -> SC) -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SC -> SC) -> ReaderT RC (State SC) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((SC -> SC) -> R ()) -> (SC -> SC) -> R ()
forall a b. (a -> b) -> a -> b
$ \SC
sc ->
    SC
sc
      { scSpanStream :: SpanStream
scSpanStream = ([RealSrcSpan] -> [RealSrcSpan]) -> SpanStream -> SpanStream
coerce ((RealSrcSpan -> Bool) -> [RealSrcSpan] -> [RealSrcSpan]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile RealSrcSpan -> Bool
leRef) (SC -> SpanStream
scSpanStream SC
sc)
      }

-- | Get location of next element in AST.
nextEltSpan :: R (Maybe RealSrcSpan)
nextEltSpan :: R (Maybe RealSrcSpan)
nextEltSpan = [RealSrcSpan] -> Maybe RealSrcSpan
forall a. [a] -> Maybe a
listToMaybe ([RealSrcSpan] -> Maybe RealSrcSpan)
-> (SpanStream -> [RealSrcSpan]) -> SpanStream -> Maybe RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanStream -> [RealSrcSpan]
coerce (SpanStream -> Maybe RealSrcSpan)
-> R SpanStream -> R (Maybe RealSrcSpan)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT RC (State SC) SpanStream -> R SpanStream
forall a. ReaderT RC (State SC) a -> R a
R ((SC -> SpanStream) -> ReaderT RC (State SC) SpanStream
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SC -> SpanStream
scSpanStream)

-- | Pop a 'Comment' from the 'CommentStream' if given predicate is
-- satisfied and there are comments in the stream.
popComment ::
  (RealLocated Comment -> Bool) ->
  R (Maybe (RealLocated Comment))
popComment :: (RealLocated Comment -> Bool) -> R (Maybe (RealLocated Comment))
popComment RealLocated Comment -> Bool
f = ReaderT RC (State SC) (Maybe (RealLocated Comment))
-> R (Maybe (RealLocated Comment))
forall a. ReaderT RC (State SC) a -> R a
R (ReaderT RC (State SC) (Maybe (RealLocated Comment))
 -> R (Maybe (RealLocated Comment)))
-> ReaderT RC (State SC) (Maybe (RealLocated Comment))
-> R (Maybe (RealLocated Comment))
forall a b. (a -> b) -> a -> b
$ do
  CommentStream [RealLocated Comment]
cstream <- (SC -> CommentStream) -> ReaderT RC (State SC) CommentStream
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SC -> CommentStream
scCommentStream
  case [RealLocated Comment]
cstream of
    [] -> Maybe (RealLocated Comment)
-> ReaderT RC (State SC) (Maybe (RealLocated Comment))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (RealLocated Comment)
forall a. Maybe a
Nothing
    (RealLocated Comment
x : [RealLocated Comment]
xs) ->
      if RealLocated Comment -> Bool
f RealLocated Comment
x
        then
          RealLocated Comment -> Maybe (RealLocated Comment)
forall a. a -> Maybe a
Just RealLocated Comment
x
            Maybe (RealLocated Comment)
-> ReaderT RC (State SC) ()
-> ReaderT RC (State SC) (Maybe (RealLocated Comment))
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (SC -> SC) -> ReaderT RC (State SC) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify
              ( \SC
sc ->
                  SC
sc
                    { scCommentStream :: CommentStream
scCommentStream = [RealLocated Comment] -> CommentStream
CommentStream [RealLocated Comment]
xs
                    }
              )
        else Maybe (RealLocated Comment)
-> ReaderT RC (State SC) (Maybe (RealLocated Comment))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (RealLocated Comment)
forall a. Maybe a
Nothing

-- | Get the first enclosing 'RealSrcSpan' that satisfies given predicate.
getEnclosingSpan ::
  -- | Predicate to use
  (RealSrcSpan -> Bool) ->
  R (Maybe RealSrcSpan)
getEnclosingSpan :: (RealSrcSpan -> Bool) -> R (Maybe RealSrcSpan)
getEnclosingSpan RealSrcSpan -> Bool
f =
  [RealSrcSpan] -> Maybe RealSrcSpan
forall a. [a] -> Maybe a
listToMaybe ([RealSrcSpan] -> Maybe RealSrcSpan)
-> ([RealSrcSpan] -> [RealSrcSpan])
-> [RealSrcSpan]
-> Maybe RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealSrcSpan -> Bool) -> [RealSrcSpan] -> [RealSrcSpan]
forall a. (a -> Bool) -> [a] -> [a]
filter RealSrcSpan -> Bool
f ([RealSrcSpan] -> Maybe RealSrcSpan)
-> R [RealSrcSpan] -> R (Maybe RealSrcSpan)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT RC (State SC) [RealSrcSpan] -> R [RealSrcSpan]
forall a. ReaderT RC (State SC) a -> R a
R ((RC -> [RealSrcSpan]) -> ReaderT RC (State SC) [RealSrcSpan]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RC -> [RealSrcSpan]
rcEnclosingSpans)

-- | Set 'RealSrcSpan' of enclosing span for the given computation.
withEnclosingSpan :: RealSrcSpan -> R () -> R ()
withEnclosingSpan :: RealSrcSpan -> R () -> R ()
withEnclosingSpan RealSrcSpan
spn (R ReaderT RC (State SC) ()
m) = ReaderT RC (State SC) () -> R ()
forall a. ReaderT RC (State SC) a -> R a
R ((RC -> RC) -> ReaderT RC (State SC) () -> ReaderT RC (State SC) ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local RC -> RC
modRC ReaderT RC (State SC) ()
m)
  where
    modRC :: RC -> RC
modRC RC
rc =
      RC
rc
        { rcEnclosingSpans :: [RealSrcSpan]
rcEnclosingSpans = RealSrcSpan
spn RealSrcSpan -> [RealSrcSpan] -> [RealSrcSpan]
forall a. a -> [a] -> [a]
: RC -> [RealSrcSpan]
rcEnclosingSpans RC
rc
        }

-- | Get spans on this line so far.
thisLineSpans :: R [RealSrcSpan]
thisLineSpans :: R [RealSrcSpan]
thisLineSpans = ReaderT RC (State SC) [RealSrcSpan] -> R [RealSrcSpan]
forall a. ReaderT RC (State SC) a -> R a
R ((SC -> [RealSrcSpan]) -> ReaderT RC (State SC) [RealSrcSpan]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SC -> [RealSrcSpan]
scThisLineSpans)

----------------------------------------------------------------------------
-- Stateful markers

-- | An auxiliary marker for keeping track of last output element.
data SpanMark
  = -- | Haddock comment
    HaddockSpan HaddockStyle RealSrcSpan
  | -- | Non-haddock comment
    CommentSpan RealSrcSpan
  | -- | A statement in a do-block and such span
    StatementSpan RealSrcSpan

-- | Project 'RealSrcSpan' from 'SpanMark'.
spanMarkSpan :: SpanMark -> RealSrcSpan
spanMarkSpan :: SpanMark -> RealSrcSpan
spanMarkSpan = \case
  HaddockSpan HaddockStyle
_ RealSrcSpan
s -> RealSrcSpan
s
  CommentSpan RealSrcSpan
s -> RealSrcSpan
s
  StatementSpan RealSrcSpan
s -> RealSrcSpan
s

-- | Haddock string style.
data HaddockStyle
  = -- | @-- |@
    Pipe
  | -- | @-- ^@
    Caret
  | -- | @-- *@
    Asterisk Int
  | -- | @-- $@
    Named String

-- | Set span of last output comment.
setSpanMark ::
  -- | Span mark to set
  SpanMark ->
  R ()
setSpanMark :: SpanMark -> R ()
setSpanMark SpanMark
spnMark = ReaderT RC (State SC) () -> R ()
forall a. ReaderT RC (State SC) a -> R a
R (ReaderT RC (State SC) () -> R ())
-> ((SC -> SC) -> ReaderT RC (State SC) ()) -> (SC -> SC) -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SC -> SC) -> ReaderT RC (State SC) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((SC -> SC) -> R ()) -> (SC -> SC) -> R ()
forall a b. (a -> b) -> a -> b
$ \SC
sc ->
  SC
sc
    { scSpanMark :: Maybe SpanMark
scSpanMark = SpanMark -> Maybe SpanMark
forall a. a -> Maybe a
Just SpanMark
spnMark
    }

-- | Get span of last output comment.
getSpanMark :: R (Maybe SpanMark)
getSpanMark :: R (Maybe SpanMark)
getSpanMark = ReaderT RC (State SC) (Maybe SpanMark) -> R (Maybe SpanMark)
forall a. ReaderT RC (State SC) a -> R a
R ((SC -> Maybe SpanMark) -> ReaderT RC (State SC) (Maybe SpanMark)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SC -> Maybe SpanMark
scSpanMark)

----------------------------------------------------------------------------
-- Annotations

-- | For a given span return 'AnnKeywordId's associated with it.
getAnns ::
  SrcSpan ->
  R [AnnKeywordId]
getAnns :: SrcSpan -> R [AnnKeywordId]
getAnns SrcSpan
spn = SrcSpan -> Anns -> [AnnKeywordId]
lookupAnns SrcSpan
spn (Anns -> [AnnKeywordId]) -> R Anns -> R [AnnKeywordId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT RC (State SC) Anns -> R Anns
forall a. ReaderT RC (State SC) a -> R a
R ((RC -> Anns) -> ReaderT RC (State SC) Anns
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RC -> Anns
rcAnns)

----------------------------------------------------------------------------
-- Helpers for braces

-- | Make the inner computation use braces around single-line layouts.
useBraces :: R () -> R ()
useBraces :: R () -> R ()
useBraces (R ReaderT RC (State SC) ()
r) = ReaderT RC (State SC) () -> R ()
forall a. ReaderT RC (State SC) a -> R a
R ((RC -> RC) -> ReaderT RC (State SC) () -> ReaderT RC (State SC) ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\RC
i -> RC
i {rcCanUseBraces :: Bool
rcCanUseBraces = Bool
True}) ReaderT RC (State SC) ()
r)

-- | Make the inner computation omit braces around single-line layouts.
dontUseBraces :: R () -> R ()
dontUseBraces :: R () -> R ()
dontUseBraces (R ReaderT RC (State SC) ()
r) = ReaderT RC (State SC) () -> R ()
forall a. ReaderT RC (State SC) a -> R a
R ((RC -> RC) -> ReaderT RC (State SC) () -> ReaderT RC (State SC) ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\RC
i -> RC
i {rcCanUseBraces :: Bool
rcCanUseBraces = Bool
False}) ReaderT RC (State SC) ()
r)

-- | Return 'True' if we can use braces in this context.
canUseBraces :: R Bool
canUseBraces :: R Bool
canUseBraces = ReaderT RC (State SC) Bool -> R Bool
forall a. ReaderT RC (State SC) a -> R a
R ((RC -> Bool) -> ReaderT RC (State SC) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RC -> Bool
rcCanUseBraces)