{-# 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,
  )
where

import Control.Monad
import Data.Text qualified as T
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.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 forall a b. (a -> b) -> a -> b
$ case SourceType
sourceType of
    SourceType
ModuleSource -> Text
"module"
    SourceType
SignatureSource -> Text
"signature"
  R ()
space
  forall a. Outputable a => a -> R ()
atom ModuleName
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
x
  IEPattern XIEPattern GhcPs
_ LIdP GhcPs
x -> do
    Text -> R ()
txt Text
"pattern"
    R ()
space
    LocatedN RdrName -> R ()
p_rdrName LIdP GhcPs
x
  IEType XIEType GhcPs
_ LIdP GhcPs
x -> do
    Text -> R ()
txt Text
"type"
    R ()
space
    LocatedN RdrName -> R ()
p_rdrName LIdP GhcPs
x

-- | Render a @'LocatedN' 'RdrName'@.
p_rdrName :: LocatedN RdrName -> R ()
p_rdrName :: LocatedN RdrName -> R ()
p_rdrName LocatedN RdrName
l = forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LocatedN RdrName
l forall a b. (a -> b) -> a -> b
$ \RdrName
x -> do
  Bool
unboxedSums <- Extension -> R Bool
isExtensionEnabled Extension
UnboxedSums
  let wrapper :: EpAnn NameAnn -> R () -> R ()
wrapper = \case
        EpAnn {NameAnn
anns :: forall ann. EpAnn ann -> ann
anns :: NameAnn
anns} -> case NameAnn
anns of
          NameAnnQuote {SrcSpanAnnN
nann_quoted :: NameAnn -> SrcSpanAnnN
nann_quoted :: SrcSpanAnnN
nann_quoted} -> forall {b}. R b -> R b
tickPrefix forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpAnn NameAnn -> R () -> R ()
wrapper (forall a. SrcSpanAnn' a -> a
ann SrcSpanAnnN
nann_quoted)
          NameAnn {nann_adornment :: NameAnn -> NameAdornment
nann_adornment = NameAdornment
NameParens} ->
            BracketStyle -> R () -> R ()
parens BracketStyle
N forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. R b -> R b
handleUnboxedSumsAndHashInteraction
          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} -> forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Text -> R ()
txt Text
"(# #)"
          NameAnn
_ -> forall a. a -> a
id
        EpAnn NameAnn
EpAnnNotUsed -> 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 :: R a -> R a
handleUnboxedSumsAndHashInteraction
        | Bool
unboxedSums,
          -- Qualified names do not start wth a `#`.
          Unqual (OccName -> String
occNameString -> Char
'#' : String
_) <- RdrName
x =
            \R a
y -> R ()
space forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> R a
y forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* R ()
space
        | Bool
otherwise = forall a. a -> a
id

  EpAnn NameAnn -> R () -> R ()
wrapper (forall a. SrcSpanAnn' a -> a
ann forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> l
getLoc forall a b. (a -> b) -> a -> b
$ LocatedN RdrName
l) forall a b. (a -> b) -> a -> b
$ case RdrName
x of
    Unqual OccName
occName ->
      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.
      forall a. Outputable a => a -> R ()
atom OccName
occName
    Exact Name
name ->
      forall a. Outputable a => a -> R ()
atom Name
name
  where
    tickPrefix :: R b -> R b
tickPrefix R b
y = Text -> R ()
txt Text
"'" 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
  forall a. Outputable a => a -> R ()
atom ModuleName
mname
  Text -> R ()
txt Text
"."
  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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [R ()]
ps
              then forall a. a -> a
id
              else BracketStyle -> R () -> R ()
parens BracketStyle
N
      R () -> R ()
parens' forall a b. (a -> b) -> a -> b
$ do
        R ()
p0
        R ()
breakpoint
        R () -> R ()
inci forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc forall a b. (a -> b) -> a -> b
$ do
          R ()
name
          R ()
space
          R ()
p1
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [R ()]
ps) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> R () -> R ()
inciIf Bool
indentArgs forall a b. (a -> b) -> a -> b
$ do
        R ()
breakpoint
        R () -> R ()
sitcc (forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
breakpoint R () -> R ()
sitcc [R ()]
ps)
    (Bool
_, [R ()]
ps) -> do
      R ()
name
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [R ()]
ps) forall a b. (a -> b) -> a -> b
$ do
        R ()
breakpoint
        Bool -> R () -> R ()
inciIf Bool
indentArgs forall a b. (a -> b) -> a -> b
$ R () -> R ()
sitcc (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 <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False SpanMark -> Bool
isCommentSpan 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.
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
goesAfterComment R ()
newline
  let docStringLines :: [Text]
docStringLines = HsDocString -> [Text]
splitDocString forall a b. (a -> b) -> a -> b
$ forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString HsDoc GhcPs
str
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
docStringLines (Bool
True forall a. a -> [a] -> [a]
: forall a. a -> [a]
repeat Bool
False)) 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
"-- " 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt Text
"--"
    R ()
space
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
x) (Text -> R ()
txt Text
x)
  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.
      R (Maybe RealSrcSpan)
getEnclosingSpan forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SpanMark -> R ()
setSpanMark 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
"-- $" 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  SourceText String
s -> Text -> R ()
txt (String -> Text
T.pack String
s)