    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE NamedFieldPuns #-}
    {-# LANGUAGE OverloadedStrings #-}

    -- | Rendering of commonly useful bits.
    module Ormolu.Printer.Meat.Common
      ( FamilyStyle (..),
        p_hsmodName,
        p_ieWrappedName,
        p_rdrName,
        p_qualName,
        p_infixDefHelper,
        p_hsDoc,
        p_hsDocName,
        p_sourceText,
      )
    where

    import Control.Monad
    import qualified Data.Text as T
    import GHC.Hs.Doc
    import GHC.Hs.Extension (GhcPs)
    import GHC.Hs.ImpExp
    import GHC.Parser.Annotation
    import GHC.Types.Name.Occurrence (OccName (..))
    import GHC.Types.Name.Reader
    import GHC.Types.SourceText
    import GHC.Types.SrcLoc
    import GHC.Unit.Module.Name
    import Ormolu.Config (SourceType (..))
    import Ormolu.Printer.Combinators
    import Ormolu.Utils

    -- | Data and type family style.
    data FamilyStyle
      = -- | Declarations in type classes
        Associated
      | -- | Top-level declarations
        Free

    -- | Outputs the name of the module-like entity, preceeded by the correct prefix ("module" or "signature").
    p_hsmodName :: ModuleName -> R ()
    p_hsmodName :: ModuleName -> R ()
    p_hsmodName ModuleName
    mname = do
      SourceType
    sourceType <- R SourceType
    askSourceType
      Text -> R ()
    txt (Text -> R ()) -> Text -> R ()
    forall a b. (a -> b) -> a -> b
    $ case SourceType
    sourceType of
        SourceType
    ModuleSource -> Text
    "module"
        SourceType
    SignatureSource -> Text
    "signature"
      R ()
    space
      ModuleName -> R ()
    forall a. Outputable a => a -> R ()
    atom ModuleName
    mname

    p_ieWrappedName :: IEWrappedName RdrName -> R ()
    p_ieWrappedName :: IEWrappedName RdrName -> R ()
    p_ieWrappedName = \case
      IEName LocatedN RdrName
    x -> LocatedN RdrName -> R ()
    p_rdrName LocatedN RdrName
    x
      IEPattern EpaLocation
    _ LocatedN RdrName
    x -> do
        Text -> R ()
    txt Text
    "pattern"
        R ()
    space
        LocatedN RdrName -> R ()
    p_rdrName LocatedN RdrName
    x
      IEType EpaLocation
    _ LocatedN RdrName
    x -> do
        Text -> R ()
    txt Text
    "type"
        R ()
    space
        LocatedN RdrName -> R ()
    p_rdrName LocatedN RdrName
    x

    -- | Render a @'LocatedN' 'RdrName'@.
    p_rdrName :: LocatedN RdrName -> R ()
    p_rdrName :: LocatedN RdrName -> R ()
    p_rdrName LocatedN RdrName
    l = LocatedN RdrName -> (RdrName -> R ()) -> R ()
    forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
    located LocatedN RdrName
    l ((RdrName -> R ()) -> R ()) -> (RdrName -> R ()) -> R ()
    forall a b. (a -> b) -> a -> b
    $ \RdrName
    x -> do
      let wrapper :: EpAnn NameAnn -> R () -> R ()
    wrapper = \case
            EpAnn {NameAnn
    anns :: NameAnn
    anns :: forall ann. EpAnn ann -> ann
    anns} -> case NameAnn
    anns of
              NameAnnQuote {SrcSpanAnnN
    nann_quoted :: SrcSpanAnnN
    nann_quoted :: NameAnn -> SrcSpanAnnN
    nann_quoted} -> R () -> R ()
    forall {b}. R b -> R b
    tickPrefix (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . EpAnn NameAnn -> R () -> R ()
    wrapper (SrcSpanAnnN -> EpAnn NameAnn
    forall a. SrcSpanAnn' a -> a
    ann SrcSpanAnnN
    nann_quoted)
              NameAnn {nann_adornment :: NameAnn -> NameAdornment
    nann_adornment = NameAdornment
    NameParens} -> BracketStyle -> R () -> R ()
    parens BracketStyle
    N
              NameAnn {nann_adornment :: NameAnn -> NameAdornment
    nann_adornment = NameAdornment
    NameBackquotes} -> R () -> R ()
    backticks
              -- special case for unboxed unit tuples
              NameAnnOnly {nann_adornment :: NameAnn -> NameAdornment
    nann_adornment = NameAdornment
    NameParensHash} -> R () -> R () -> R ()
    forall a b. a -> b -> a
    const (R () -> R () -> R ()) -> R () -> R () -> R ()
    forall a b. (a -> b) -> a -> b
    $ Text -> R ()
    txt Text
    "(# #)"
              NameAnn
    _ -> R () -> R ()
    forall a. a -> a
    id
            EpAnn NameAnn
    EpAnnNotUsed -> R () -> R ()
    forall a. a -> a
    id
      EpAnn NameAnn -> R () -> R ()
    wrapper (SrcSpanAnnN -> EpAnn NameAnn
    forall a. SrcSpanAnn' a -> a
    ann (SrcSpanAnnN -> EpAnn NameAnn)
    -> (LocatedN RdrName -> SrcSpanAnnN)
    -> LocatedN RdrName
    -> EpAnn NameAnn
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LocatedN RdrName -> SrcSpanAnnN
    forall l e. GenLocated l e -> l
    getLoc (LocatedN RdrName -> EpAnn NameAnn)
    -> LocatedN RdrName -> EpAnn NameAnn
    forall a b. (a -> b) -> a -> b
    $ LocatedN RdrName
    l) (R () -> R ()) -> R () -> R ()
    forall a b. (a -> b) -> a -> b
    $ case RdrName
    x of
        Unqual OccName
    occName ->
          OccName -> R ()
    forall a. Outputable a => a -> R ()
    atom OccName
    occName
        Qual ModuleName
    mname OccName
    occName ->
          ModuleName -> OccName -> R ()
    p_qualName ModuleName
    mname OccName
    occName
        Orig Module
    _ OccName
    occName ->
          -- This is used when GHC generates code that will be fed into
          -- the renamer (e.g. from deriving clauses), but where we want
          -- to say that something comes from given module which is not
          -- specified in the source code, e.g. @Prelude.map@.
          --
          -- My current understanding is that the provided module name
          -- serves no purpose for us and can be safely ignored.
          OccName -> R ()
    forall a. Outputable a => a -> R ()
    atom OccName
    occName
        Exact Name
    name ->
          Name -> R ()
    forall a. Outputable a => a -> R ()
    atom Name
    name
      where
        tickPrefix :: R b -> R b
    tickPrefix R b
    y = Text -> R ()
    txt Text
    "'" R () -> R b -> R b
    forall a b. R a -> R b -> R b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> R b
    y

    p_qualName :: ModuleName -> OccName -> R ()
    p_qualName :: ModuleName -> OccName -> R ()
    p_qualName ModuleName
    mname OccName
    occName = do
      ModuleName -> R ()
    forall a. Outputable a => a -> R ()
    atom ModuleName
    mname
      Text -> R ()
    txt Text
    "."
      OccName -> R ()
    forall a. Outputable a => a -> R ()
    atom OccName
    occName

    -- | A helper for formatting infix constructions in lhs of definitions.
    p_infixDefHelper ::
      -- | Whether to format in infix style
      Bool ->
      -- | Whether to bump indentation for arguments
      Bool ->
      -- | How to print the operator\/name
      R () ->
      -- | How to print the arguments
      [R ()] ->
      R ()
    p_infixDefHelper :: Bool -> Bool -> R () -> [R ()] -> R ()
    p_infixDefHelper Bool
    isInfix Bool
    indentArgs R ()
    name [R ()]
    args =
      case (Bool
    isInfix, [R ()]
    args) of
        (Bool
    True, R ()
    p0 : R ()
    p1 : [R ()]
    ps) -> do
          let parens' :: R () -> R ()
    parens' =
                if [R ()] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [R ()]
    ps
                  then R () -> R ()
    forall a. a -> a
    id
                  else BracketStyle -> R () -> R ()
    parens BracketStyle
    N
          R () -> R ()
    parens' (R () -> R ()) -> R () -> R ()
    forall a b. (a -> b) -> a -> b
    $ do
            R ()
    p0
            R ()
    breakpoint
            R () -> R ()
    inci (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . R () -> R ()
    sitcc (R () -> R ()) -> R () -> R ()
    forall a b. (a -> b) -> a -> b
    $ do
              R ()
    name
              R ()
    space
              R ()
    p1
          Bool -> R () -> R ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless ([R ()] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [R ()]
    ps) (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Bool -> R () -> R ()
    inciIf Bool
    indentArgs (R () -> R ()) -> R () -> R ()
    forall a b. (a -> b) -> a -> b
    $ do
            R ()
    breakpoint
            R () -> R ()
    sitcc (R () -> (R () -> R ()) -> [R ()] -> R ()
    forall a. R () -> (a -> R ()) -> [a] -> R ()
    sep R ()
    breakpoint R () -> R ()
    sitcc [R ()]
    ps)
        (Bool
    _, [R ()]
    ps) -> do
          R ()
    name
          Bool -> R () -> R ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless ([R ()] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [R ()]
    ps) (R () -> R ()) -> R () -> R ()
    forall a b. (a -> b) -> a -> b
    $ do
            R ()
    breakpoint
            Bool -> R () -> R ()
    inciIf Bool
    indentArgs (R () -> R ()) -> R () -> R ()
    forall a b. (a -> b) -> a -> b
    $ R () -> R ()
    sitcc (R () -> (R () -> R ()) -> [R ()] -> R ()
    forall a. R () -> (a -> R ()) -> [a] -> R ()
    sep R ()
    breakpoint R () -> R ()
    sitcc [R ()]
    args)

    -- | Print a Haddock.
    p_hsDoc ::
      -- | Haddock style
      HaddockStyle ->
      -- | Finish the doc string with a newline
      Bool ->
      -- | The 'LHsDoc' to render
      LHsDoc GhcPs ->
      R ()
    p_hsDoc :: HaddockStyle -> Bool -> LHsDoc GhcPs -> R ()
    p_hsDoc HaddockStyle
    hstyle Bool
    needsNewline (L SrcSpan
    l HsDoc GhcPs
    str) = do
      let isCommentSpan :: SpanMark -> Bool
    isCommentSpan = \case
            HaddockSpan HaddockStyle
    _ RealSrcSpan
    _ -> Bool
    True
            CommentSpan RealSrcSpan
    _ -> Bool
    True
            SpanMark
    _ -> Bool
    False
      Bool
    goesAfterComment <- Bool -> (SpanMark -> Bool) -> Maybe SpanMark -> Bool
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Bool
    False SpanMark -> Bool
    isCommentSpan (Maybe SpanMark -> Bool) -> R (Maybe SpanMark) -> R Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> R (Maybe SpanMark)
    getSpanMark
      -- Make sure the Haddock is separated by a newline from other comments.
      Bool -> R () -> R ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    goesAfterComment R ()
    newline
      let docStringLines :: [Text]
    docStringLines = HsDocString -> [Text]
    splitDocString (HsDocString -> [Text]) -> HsDocString -> [Text]
    forall a b. (a -> b) -> a -> b
    $ HsDoc GhcPs -> HsDocString
    forall a pass. WithHsDocIdentifiers a pass -> a
    hsDocString HsDoc GhcPs
    str
      [(Text, Bool)] -> ((Text, Bool) -> R ()) -> R ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ ([Text] -> [Bool] -> [(Text, Bool)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Text]
    docStringLines (Bool
    True Bool -> [Bool] -> [Bool]
    forall a. a -> [a] -> [a]
    : Bool -> [Bool]
    forall a. a -> [a]
    repeat Bool
    False)) (((Text, Bool) -> R ()) -> R ()) -> ((Text, Bool) -> R ()) -> R ()
    forall a b. (a -> b) -> a -> b
    $ \(Text
    x, Bool
    isFirst) -> do
        if Bool
    isFirst
          then case HaddockStyle
    hstyle of
            HaddockStyle
    Pipe -> Text -> R ()
    txt Text
    "-- |"
            HaddockStyle
    Caret -> Text -> R ()
    txt Text
    "-- ^"
            Asterisk Int
    n -> Text -> R ()
    txt (Text
    "-- " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Int -> Text -> Text
    T.replicate Int
    n Text
    "*")
            Named String
    name -> String -> R ()
    p_hsDocName String
    name
          else R ()
    newline R () -> R () -> R ()
    forall a b. R a -> R b -> R b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Text -> R ()
    txt Text
    "--"
        R ()
    space
        Bool -> R () -> R ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (Text -> Bool
    T.null Text
    x) (Text -> R ()
    txt Text
    x)
      Bool -> R () -> R ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    needsNewline R ()
    newline
      case SrcSpan
    l of
        UnhelpfulSpan UnhelpfulSpanReason
    _ ->
          -- It's often the case that the comment itself doesn't have a span
          -- attached to it and instead its location can be obtained from
          -- nearest enclosing span.
          (RealSrcSpan -> Bool) -> R (Maybe RealSrcSpan)
    getEnclosingSpan (Bool -> RealSrcSpan -> Bool
    forall a b. a -> b -> a
    const Bool
    True) R (Maybe RealSrcSpan) -> (Maybe RealSrcSpan -> R ()) -> R ()
    forall a b. R a -> (a -> R b) -> R b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (RealSrcSpan -> R ()) -> Maybe RealSrcSpan -> R ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (SpanMark -> R ()
    setSpanMark (SpanMark -> R ())
    -> (RealSrcSpan -> SpanMark) -> RealSrcSpan -> R ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . HaddockStyle -> RealSrcSpan -> SpanMark
    HaddockSpan HaddockStyle
    hstyle)
        RealSrcSpan RealSrcSpan
    spn Maybe BufSpan
    _ -> SpanMark -> R ()
    setSpanMark (HaddockStyle -> RealSrcSpan -> SpanMark
    HaddockSpan HaddockStyle
    hstyle RealSrcSpan
    spn)

    -- | Print anchor of named doc section.
    p_hsDocName :: String -> R ()
    p_hsDocName :: String -> R ()
    p_hsDocName String
    name = Text -> R ()
    txt (Text
    "-- $" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> String -> Text
    T.pack String
    name)

    p_sourceText :: SourceText -> R ()
    p_sourceText :: SourceText -> R ()
    p_sourceText = \case
      SourceText
    NoSourceText -> () -> R ()
    forall a. a -> R a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
      SourceText String
    s -> R ()
    space R () -> R () -> R ()
    forall a b. R a -> R b -> R b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Text -> R ()
    txt (String -> Text
    T.pack String
    s)