Common.hs

{-# 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_hsDoc',
    p_sourceText,
    p_namespaceSpec,
    p_hsMultAnn,
    p_arrow,
  )
where

import Control.Monad
import Data.Choice (Choice)
import Data.Choice qualified as Choice
import Data.Foldable (traverse_)
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.Hs.Type
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.Module.Name
import Ormolu.Config
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, preceded by the correct prefix ("module" or "signature").
p_hsmodName :: ModuleName -> R ()
p_hsmodName mname = do
  sourceType <- askSourceType
  txt $ case sourceType of
    ModuleSource -> "module"
    SignatureSource -> "signature"
  space
  atom mname

p_ieWrappedName :: IEWrappedName GhcPs -> R ()
p_ieWrappedName = \case
  IEName _ x -> p_rdrName x
  IEDefault _ x -> do
    txt "default"
    space
    p_rdrName x
  IEPattern _ x -> do
    txt "pattern"
    space
    p_rdrName x
  IEType _ x -> do
    txt "type"
    space
    p_rdrName x
  IEData _ x -> do
    txt "data"
    space
    p_rdrName x

-- | Render a @'LocatedN' 'RdrName'@.
p_rdrName :: LocatedN RdrName -> R ()
p_rdrName l = located l $ \x -> do
  unboxedSums <- isExtensionEnabled UnboxedSums
  let wrapper EpAnn {anns} = case anns of
        NameAnnQuote {nann_quoted} -> tickPrefix . wrapper nann_quoted
        NameAnn {nann_adornment = NameParens {}} ->
          parens N . handleUnboxedSumsAndHashInteraction
        NameAnn {nann_adornment = NameBackquotes {}} -> backticks
        -- whether the `->` identifier is parenthesized
        NameAnnRArrow {nann_mopen = Just _} -> parens N
        -- special case for unboxed unit tuples
        NameAnnOnly {nann_adornment = NameParensHash {}} -> const $ txt "(# #)"
        _ -> id

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

  wrapper (getLoc l) $ case x of
    Unqual occName ->
      atom occName
    Qual mname occName ->
      p_qualName mname occName
    Orig _ 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.
      atom occName
    Exact name ->
      atom name
  where
    tickPrefix y = txt "'" *> y

p_qualName :: ModuleName -> OccName -> R ()
p_qualName mname occName = do
  atom mname
  txt "."
  atom 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 isInfix indentArgs name args =
  case (isInfix, args) of
    (True, p0 : p1 : ps) -> do
      let parens' =
            if null ps
              then id
              else parens N . sitcc
      parens' $ do
        p0
        breakpoint
        inci . sitcc $ do
          name
          space
          p1
      unless (null ps) . inciIf indentArgs $ do
        breakpoint
        sitcc (sep breakpoint sitcc ps)
    (_, ps) -> do
      name
      unless (null ps) $ do
        breakpoint
        inciIf indentArgs $ sitcc (sep breakpoint sitcc 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 hstyle needsNewline lstr = do
  poHStyle <- getPrinterOpt poHaddockStyle
  p_hsDoc' poHStyle hstyle needsNewline lstr

-- | Print a Haddock.
p_hsDoc' ::
  -- | 'haddock-style' configuration option
  HaddockPrintStyle ->
  -- | Haddock style
  HaddockStyle ->
  -- | Finish the doc string with a newline
  Choice "endNewline" ->
  -- | The 'LHsDoc' to render
  LHsDoc GhcPs ->
  R ()
p_hsDoc' poHStyle hstyle needsNewline (L l str) = do
  let isCommentSpan = \case
        HaddockSpan _ _ -> True
        CommentSpan _ -> True
        _ -> False
  goesAfterComment <- maybe False isCommentSpan <$> getSpanMark
  -- Make sure the Haddock is separated by a newline from other comments.
  when goesAfterComment newline

  let docStringLines = splitDocString $ hsDocString str

  if poHStyle == HaddockSingleLine || length docStringLines <= 1
    then do
      txt $ "-- " <> haddockDelim
      space
      sep (newline >> txt "--" >> space) txt docStringLines
    else do
      txt . T.concat $
        [ "{-",
          case (hstyle, poHStyle) of
            (Pipe, HaddockMultiLineCompact) -> ""
            _ -> " ",
          haddockDelim
        ]
      space
      sep multilineCommentNewline txtStripIndent docStringLines
      newline
      txt "-}"

  when (Choice.isTrue needsNewline) newline
  traverse_ (setSpanMark . HaddockSpan hstyle) =<< getSrcSpan l
  where
    haddockDelim =
      case hstyle of
        Pipe -> "|"
        Caret -> "^"
        Asterisk n -> T.replicate n "*"
        Named name -> "$" <> T.pack name
    getSrcSpan = \case
      -- 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.
      UnhelpfulSpan _ -> getEnclosingSpan
      RealSrcSpan spn _ -> pure $ Just spn

p_sourceText :: SourceText -> R ()
p_sourceText = \case
  NoSourceText -> pure ()
  SourceText s -> atom @FastString s

p_namespaceSpec :: NamespaceSpecifier -> R ()
p_namespaceSpec = \case
  NoNamespaceSpecifier -> pure ()
  TypeNamespaceSpecifier _ -> txt "type" *> space
  DataNamespaceSpecifier _ -> txt "data" *> space

p_hsMultAnn :: (mult -> R ()) -> HsMultAnnOf mult GhcPs -> R ()
p_hsMultAnn p_mult = \case
  HsUnannotated _ -> pure ()
  HsLinearAnn _ -> txt "%1"
  HsExplicitMult _ mult -> txt "%" *> p_mult mult

-- | Like 'p_hsMultAnn', except specifically for arrows, taking -XUnicodeSyntax
--   into account.
p_arrow :: (mult -> R ()) -> HsMultAnnOf mult GhcPs -> R ()
p_arrow p_mult = \case
  HsUnannotated _ -> token'rarrow
  HsLinearAnn _ -> token'lolly
  HsExplicitMult _ mult -> do
    txt "%"
    p_mult mult
    space
    token'rarrow