    {-# LANGUAGE DataKinds #-}
    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE ViewPatterns #-}

    -- | 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,
        p_namespaceSpec,
        p_arrow,
      )
    where

    import Control.Monad
    import Data.Choice (Choice)
    import Data.Choice qualified as Choice
    import Data.Text qualified as T
    import GHC.Data.FastString
    import GHC.Hs.Binds
    import GHC.Hs.Doc
    import GHC.Hs.Extension (GhcPs)
    import GHC.Hs.ImpExp
    import GHC.LanguageExtensions.Type (Extension (..))
    import GHC.Parser.Annotation
    import GHC.Types.Name.Occurrence (OccName (..), occNameString)
    import GHC.Types.Name.Reader
    import GHC.Types.SourceText
    import GHC.Types.SrcLoc
    import Language.Haskell.Syntax (HsArrowOf (..))
    import Language.Haskell.Syntax.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 <- R SourceType
    askSourceType
      txt $ case sourceType of
        SourceType
    ModuleSource -> Text
    "module"
        SourceType
    SignatureSource -> Text
    "signature"
      space
      atom mname

    p_ieWrappedName :: IEWrappedName GhcPs -> R ()
    p_ieWrappedName :: IEWrappedName GhcPs -> R ()
    p_ieWrappedName = \case
      IEName XIEName GhcPs
    _ LIdP GhcPs
    x -> LocatedN RdrName -> R ()
    p_rdrName LIdP GhcPs
    LocatedN RdrName
    x
      IEDefault XIEDefault GhcPs
    _ LIdP GhcPs
    x -> do
        Text -> R ()
    txt Text
    "default"
        R ()
    space
        LocatedN RdrName -> R ()
    p_rdrName LIdP GhcPs
    LocatedN RdrName
    x
      IEPattern XIEPattern GhcPs
    _ LIdP GhcPs
    x -> do
        Text -> R ()
    txt Text
    "pattern"
        R ()
    space
        LocatedN RdrName -> R ()
    p_rdrName LIdP GhcPs
    LocatedN RdrName
    x
      IEType XIEType GhcPs
    _ LIdP GhcPs
    x -> do
        Text -> R ()
    txt Text
    "type"
        R ()
    space
        LocatedN RdrName -> R ()
    p_rdrName LIdP GhcPs
    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. HasLoc 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
      unboxedSums <- Extension -> R Bool
    isExtensionEnabled Extension
    UnboxedSums
      let wrapper 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
    . SrcSpanAnnN -> R () -> R ()
    wrapper SrcSpanAnnN
    nann_quoted
            NameAnn {nann_adornment :: NameAnn -> NameAdornment
    nann_adornment = NameParens {}} ->
              BracketStyle -> R () -> R ()
    parens BracketStyle
    N (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . R () -> R ()
    forall {b}. R b -> R b
    handleUnboxedSumsAndHashInteraction
            NameAnn {nann_adornment :: NameAnn -> NameAdornment
    nann_adornment = NameBackquotes {}} -> R () -> R ()
    backticks
            -- whether the `->` identifier is parenthesized
            NameAnnRArrow {nann_mopen :: NameAnn -> Maybe (EpToken "(")
    nann_mopen = Just EpToken "("
    _} -> BracketStyle -> R () -> R ()
    parens BracketStyle
    N
            -- special case for unboxed unit tuples
            NameAnnOnly {nann_adornment :: NameAnn -> NameAdornment
    nann_adornment = 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

          -- When UnboxedSums is enabled, `(#` is a single lexeme, so we have to
          -- insert spaces when we have a parenthesized operator starting with `#`.
          handleUnboxedSumsAndHashInteraction
            | Bool
    unboxedSums,
              -- Qualified names do not start wth a `#`.
              Unqual (OccName -> String
    occNameString -> Char
    '#' : String
    _) <- RdrName
    x =
                \R a
    y -> R ()
    space R () -> R a -> R a
    forall a b. R a -> R b -> R b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> R a
    y R a -> R () -> R a
    forall a b. R a -> R b -> R a
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
    <* R ()
    space
            | Bool
    otherwise = R a -> R a
    forall a. a -> a
    id

      wrapper (getLoc l) $ case 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
      Choice "endNewline" ->
      -- | The 'LHsDoc' to render
      LHsDoc GhcPs ->
      R ()
    p_hsDoc :: HaddockStyle -> Choice "endNewline" -> LHsDoc GhcPs -> R ()
    p_hsDoc HaddockStyle
    hstyle Choice "endNewline"
    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
      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.
      when goesAfterComment newline
      let 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
      forM_ (zip docStringLines (True : repeat False)) $ \(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)
      when (Choice.isTrue needsNewline) newline
      case 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.
          R (Maybe RealSrcSpan)
    getEnclosingSpan 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 FastString
    s -> forall a. Outputable a => a -> R ()
    atom @FastString FastString
    s

    p_namespaceSpec :: NamespaceSpecifier -> R ()
    p_namespaceSpec :: NamespaceSpecifier -> R ()
    p_namespaceSpec = \case
      NamespaceSpecifier
    NoNamespaceSpecifier -> () -> R ()
    forall a. a -> R a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
      TypeNamespaceSpecifier EpToken "type"
    _ -> Text -> R ()
    txt Text
    "type" R () -> R () -> R ()
    forall a b. R a -> R b -> R b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> R ()
    space
      DataNamespaceSpecifier EpToken "data"
    _ -> Text -> R ()
    txt Text
    "data" R () -> R () -> R ()
    forall a b. R a -> R b -> R b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> R ()
    space

    p_arrow :: (mult -> R ()) -> HsArrowOf mult GhcPs -> R ()
    p_arrow :: forall mult. (mult -> R ()) -> HsArrowOf mult GhcPs -> R ()
    p_arrow mult -> R ()
    p_mult = \case
      HsUnrestrictedArrow XUnrestrictedArrow mult GhcPs
    _ -> Text -> R ()
    txt Text
    "->"
      HsLinearArrow XLinearArrow mult GhcPs
    _ -> Text -> R ()
    txt Text
    "%1 ->"
      HsExplicitMult XExplicitMult mult GhcPs
    _ mult
    mult -> do
        Text -> R ()
    txt Text
    "%"
        mult -> R ()
    p_mult mult
    mult
        R ()
    space
        Text -> R ()
    txt Text
    "->"