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

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

    import Control.Monad
    import Data.List (isPrefixOf)
    import qualified Data.Text as T
    import GHC hiding (GhcPs, IE)
    import Name (nameStableString)
    import OccName (OccName (..))
    import Ormolu.Printer.Combinators
    import Ormolu.Utils

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

    p_hsmodName :: ModuleName -> R ()
    p_hsmodName :: ModuleName -> R ()
    p_hsmodName mname :: ModuleName
    mname = do
      Text -> R ()
    txt "module"
      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 x :: Located RdrName
    x -> Located RdrName -> R ()
    p_rdrName Located RdrName
    x
      IEPattern x :: Located RdrName
    x -> do
        Text -> R ()
    txt "pattern"
        R ()
    space
        Located RdrName -> R ()
    p_rdrName Located RdrName
    x
      IEType x :: Located RdrName
    x -> do
        Text -> R ()
    txt "type"
        R ()
    space
        Located RdrName -> R ()
    p_rdrName Located RdrName
    x

    -- | Render a @'Located' 'RdrName'@.
    p_rdrName :: Located RdrName -> R ()
    p_rdrName :: Located RdrName -> R ()
    p_rdrName l :: Located RdrName
    l@(L spn :: SrcSpan
    spn _) = Located RdrName -> (RdrName -> R ()) -> R ()
    forall a. Located a -> (a -> R ()) -> R ()
    located Located RdrName
    l ((RdrName -> R ()) -> R ()) -> (RdrName -> R ()) -> R ()
    forall a b. (a -> b) -> a -> b
    $ \x :: RdrName
    x -> do
      [AnnKeywordId]
    ids <- SrcSpan -> R [AnnKeywordId]
    getAnns SrcSpan
    spn
      let backticksWrapper :: R () -> R ()
    backticksWrapper =
            if AnnKeywordId
    AnnBackquote AnnKeywordId -> [AnnKeywordId] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [AnnKeywordId]
    ids
              then R () -> R ()
    backticks
              else R () -> R ()
    forall a. a -> a
    id
          parensWrapper :: R () -> R ()
    parensWrapper =
            if AnnKeywordId
    AnnOpenP AnnKeywordId -> [AnnKeywordId] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [AnnKeywordId]
    ids
              then BracketStyle -> R () -> R ()
    parens BracketStyle
    N
              else R () -> R ()
    forall a. a -> a
    id
          singleQuoteWrapper :: R b -> R b
    singleQuoteWrapper =
            if AnnKeywordId
    AnnSimpleQuote AnnKeywordId -> [AnnKeywordId] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [AnnKeywordId]
    ids
              then \y :: R b
    y -> do
                Text -> R ()
    txt "'"
                R b
    y
              else R b -> R b
    forall a. a -> a
    id
          m :: R ()
    m =
            case RdrName
    x of
              Unqual occName :: OccName
    occName ->
                OccName -> R ()
    forall a. Outputable a => a -> R ()
    atom OccName
    occName
              Qual mname :: ModuleName
    mname occName :: OccName
    occName ->
                ModuleName -> OccName -> R ()
    p_qualName ModuleName
    mname OccName
    occName
              Orig _ occName :: 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 ->
                Name -> R ()
    forall a. Outputable a => a -> R ()
    atom Name
    name
          m' :: R ()
    m' = R () -> R ()
    backticksWrapper (R () -> R ()
    forall b. R b -> R b
    singleQuoteWrapper R ()
    m)
      if RdrName -> Bool
    doesNotNeedExtraParens RdrName
    x
        then R ()
    m'
        else R () -> R ()
    parensWrapper R ()
    m'

    -- | Whether given name should not have parentheses around it. This is used
    -- to detect e.g. tuples for which annotations will indicate parentheses,
    -- but the parentheses are already part of the symbol, so no extra layer of
    -- parentheses should be added. It also detects the [] literal.
    doesNotNeedExtraParens :: RdrName -> Bool
    doesNotNeedExtraParens :: RdrName -> Bool
    doesNotNeedExtraParens = \case
      Exact name :: Name
    name ->
        let s :: String
    s = Name -> String
    nameStableString Name
    name
         in -- I'm not sure this "stable string" is stable enough, but it looks
            -- like this is the most robust way to tell if we're looking at
            -- exactly this piece of built-in syntax.
            ("$ghc-prim$GHC.Tuple$" String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isPrefixOf` String
    s)
              Bool -> Bool -> Bool
    || ("$ghc-prim$GHC.Types$[]" String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isPrefixOf` String
    s)
      _ -> Bool
    False

    p_qualName :: ModuleName -> OccName -> R ()
    p_qualName :: ModuleName -> OccName -> R ()
    p_qualName mname :: ModuleName
    mname occName :: OccName
    occName = do
      ModuleName -> R ()
    forall a. Outputable a => a -> R ()
    atom ModuleName
    mname
      Text -> R ()
    txt "."
      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 isInfix :: Bool
    isInfix indentArgs :: Bool
    indentArgs name :: R ()
    name args :: [R ()]
    args =
      case (Bool
    isInfix, [R ()]
    args) of
        (True, p0 :: R ()
    p0 : p1 :: R ()
    p1 : ps :: [R ()]
    ps) -> do
          let parens' :: R () -> R ()
    parens' =
                if [R ()] -> 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 (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)
        (_, ps :: [R ()]
    ps) -> do
          R ()
    name
          Bool -> R () -> R ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless ([R ()] -> 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_hsDocString ::
      -- | Haddock style
      HaddockStyle ->
      -- | Finish the doc string with a newline
      Bool ->
      -- | The doc string to render
      LHsDocString ->
      R ()
    p_hsDocString :: HaddockStyle -> Bool -> LHsDocString -> R ()
    p_hsDocString hstyle :: HaddockStyle
    hstyle needsNewline :: Bool
    needsNewline (L l :: SrcSpan
    l str :: HsDocString
    str) = do
      let isCommentSpan :: SpanMark -> Bool
    isCommentSpan = \case
            HaddockSpan _ _ -> Bool
    True
            CommentSpan _ -> Bool
    True
            _ -> 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
      [(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 (HsDocString -> [Text]
    splitDocString HsDocString
    str) (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
    $ \(x :: Text
    x, isFirst :: Bool
    isFirst) -> do
        if Bool
    isFirst
          then case HaddockStyle
    hstyle of
            Pipe -> Text -> R ()
    txt "-- |"
            Caret -> Text -> R ()
    txt "-- ^"
            Asterisk n :: Int
    n -> Text -> R ()
    txt ("-- " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Int -> Text -> Text
    T.replicate Int
    n "*")
            Named name :: String
    name -> String -> R ()
    p_hsDocName String
    name
          else R ()
    newline R () -> R () -> R ()
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Text -> R ()
    txt "--"
        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 _ ->
          -- 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 (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 spn :: RealSrcSpan
    spn -> 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 name :: String
    name = Text -> R ()
    txt ("-- $" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> String -> Text
    T.pack String
    name)