{-# 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,
    useRecordDot,
    inci,
    inciHalf,
    sitcc,
    Layout (..),
    enterLayout,
    vlayout,
    getLayout,

    -- * 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,

    -- * Extensions
    isExtensionEnabled,
  )
where

import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Bool (bool)
import Data.Coerce
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.Data.EnumSet (EnumSet)
import qualified GHC.Data.EnumSet as EnumSet
import GHC.LanguageExtensions.Type
import GHC.Parser.Annotation
import GHC.Types.SrcLoc
import GHC.Utils.Outputable (Outputable)
import Ormolu.Parser.Anns
import Ormolu.Parser.CommentStream
import Ormolu.Printer.SpanStream
import Ormolu.Utils (showOutputable)

----------------------------------------------------------------------------
-- 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,
    -- | Enabled extensions
    RC -> EnumSet Extension
rcExtensions :: EnumSet Extension
  }

-- | 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 'R' monad.
runR ::
  -- | Monad to run
  R () ->
  -- | Span stream
  SpanStream ->
  -- | Comment stream
  CommentStream ->
  -- | Annotations
  Anns ->
  -- | Use Record Dot Syntax
  Bool ->
  -- | Enabled extensions
  EnumSet Extension ->
  -- | Resulting rendition
  Text
runR :: R ()
-> SpanStream
-> CommentStream
-> Anns
-> Bool
-> EnumSet Extension
-> Text
runR (R ReaderT RC (State SC) ()
m) SpanStream
sstream CommentStream
cstream Anns
anns Bool
recDot EnumSet Extension
extensions =
  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
-> EnumSet Extension
-> 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,
          rcExtensions :: EnumSet Extension
rcExtensions = EnumSet Extension
extensions
        }
    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
    }

-- | 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 = 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
   in SC
sc
        { scBuilder :: Builder
scBuilder = case RequestedDelimiter
requestedDel of
            RequestedDelimiter
AfterNewline -> Builder
builderSoFar
            RequestedDelimiter
RequestedNewline -> Builder
builderSoFar
            RequestedDelimiter
VeryBeginning -> Builder
builderSoFar
            RequestedDelimiter
_ -> Builder
builderSoFar Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> 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)

inciBy :: Int -> R () -> R ()
inciBy :: Int -> R () -> R ()
inciBy Int
step (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
        { rcIndent :: Int
rcIndent = RC -> Int
rcIndent RC
rc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
step
        }

-- | 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
indentStep

-- | In rare cases, we have to indent by a positive amount smaller
-- than 'indentStep'.
inciHalf :: R () -> R ()
inciHalf :: R () -> R ()
inciHalf = Int -> R () -> R ()
inciBy (Int -> R () -> R ()) -> Int -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ (Int
indentStep Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` Int
1

-- | 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)

----------------------------------------------------------------------------
-- 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)

----------------------------------------------------------------------------
-- Constants

-- | Indentation step.
indentStep :: Int
indentStep :: Int
indentStep = Int
2

----------------------------------------------------------------------------
-- Extensions

isExtensionEnabled :: Extension -> R Bool
isExtensionEnabled :: Extension -> R Bool
isExtensionEnabled Extension
ext = ReaderT RC (State SC) Bool -> R Bool
forall a. ReaderT RC (State SC) a -> R a
R (ReaderT RC (State SC) Bool -> R Bool)
-> ((RC -> Bool) -> ReaderT RC (State SC) Bool)
-> (RC -> Bool)
-> R Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RC -> Bool) -> ReaderT RC (State SC) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((RC -> Bool) -> R Bool) -> (RC -> Bool) -> R Bool
forall a b. (a -> b) -> a -> b
$ Extension -> EnumSet Extension -> Bool
forall a. Enum a => a -> EnumSet a -> Bool
EnumSet.member Extension
ext (EnumSet Extension -> Bool)
-> (RC -> EnumSet Extension) -> RC -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RC -> EnumSet Extension
rcExtensions