{-# 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_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.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
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 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
  Bool
unboxedSums <- Extension -> R Bool
isExtensionEnabled Extension
UnboxedSums
  let wrapper :: SrcSpanAnnN -> R () -> R ()
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 :: 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 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

  SrcSpanAnnN -> R () -> R ()
wrapper (LocatedN RdrName -> SrcSpanAnnN
forall l e. GenLocated l e -> l
getLoc 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 ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc
      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 LHsDoc GhcPs
lstr = do
  HaddockPrintStyle
poHStyle <- (forall (f :: * -> *). PrinterOpts f -> f HaddockPrintStyle)
-> R HaddockPrintStyle
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt PrinterOpts f -> f HaddockPrintStyle
forall (f :: * -> *). PrinterOpts f -> f HaddockPrintStyle
poHaddockStyle
  HaddockPrintStyle
-> HaddockStyle -> Choice "endNewline" -> LHsDoc GhcPs -> R ()
p_hsDoc' HaddockPrintStyle
poHStyle HaddockStyle
hstyle Choice "endNewline"
needsNewline LHsDoc GhcPs
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' :: HaddockPrintStyle
-> HaddockStyle -> Choice "endNewline" -> LHsDoc GhcPs -> R ()
p_hsDoc' HaddockPrintStyle
poHStyle 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
  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 shouldEscapeCommentBraces :: Bool
shouldEscapeCommentBraces =
        case HaddockPrintStyle
poHStyle of
          HaddockPrintStyle
HaddockSingleLine -> Bool
False
          HaddockPrintStyle
HaddockMultiLine -> Bool
True
          HaddockPrintStyle
HaddockMultiLineCompact -> Bool
True
  let docStringLines :: [Text]
docStringLines = Bool -> HsDocString -> [Text]
splitDocString Bool
shouldEscapeCommentBraces (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

  if HaddockPrintStyle
poHStyle HaddockPrintStyle -> HaddockPrintStyle -> Bool
forall a. Eq a => a -> a -> Bool
== HaddockPrintStyle
HaddockSingleLine Bool -> Bool -> Bool
|| [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
docStringLines Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
    then do
      Text -> R ()
txt (Text -> R ()) -> Text -> R ()
forall a b. (a -> b) -> a -> b
$ Text
"-- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
haddockDelim
      R ()
space
      R () -> (Text -> R ()) -> [Text] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (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 () -> R () -> R ()
forall a b. R a -> R b -> R b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space) Text -> R ()
txt [Text]
docStringLines
    else do
      Text -> R ()
txt (Text -> R ()) -> ([Text] -> Text) -> [Text] -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat ([Text] -> R ()) -> [Text] -> R ()
forall a b. (a -> b) -> a -> b
$
        [ Text
"{-",
          case (HaddockStyle
hstyle, HaddockPrintStyle
poHStyle) of
            (HaddockStyle
Pipe, HaddockPrintStyle
HaddockMultiLineCompact) -> Text
""
            (HaddockStyle, HaddockPrintStyle)
_ -> Text
" ",
          Text
haddockDelim
        ]
      R ()
space
      R () -> (Text -> R ()) -> [Text] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
multilineCommentNewline Text -> R ()
txtStripIndent [Text]
docStringLines
      R ()
newline
      Text -> R ()
txt Text
"-}"

  Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Choice "endNewline" -> Bool
forall (a :: Symbol). Choice a -> Bool
Choice.isTrue Choice "endNewline"
needsNewline) R ()
newline
  (RealSrcSpan -> R ()) -> Maybe RealSrcSpan -> R ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (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) (Maybe RealSrcSpan -> R ()) -> R (Maybe RealSrcSpan) -> R ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SrcSpan -> R (Maybe RealSrcSpan)
getSrcSpan SrcSpan
l
  where
    haddockDelim :: Text
haddockDelim =
      case HaddockStyle
hstyle of
        HaddockStyle
Pipe -> Text
"|"
        HaddockStyle
Caret -> Text
"^"
        Asterisk Int
n -> Int -> Text -> Text
T.replicate Int
n Text
"*"
        Named String
name -> Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
name
    getSrcSpan :: SrcSpan -> R (Maybe RealSrcSpan)
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 UnhelpfulSpanReason
_ -> R (Maybe RealSrcSpan)
getEnclosingSpan
      RealSrcSpan RealSrcSpan
spn Maybe BufSpan
_ -> Maybe RealSrcSpan -> R (Maybe RealSrcSpan)
forall a. a -> R a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe RealSrcSpan -> R (Maybe RealSrcSpan))
-> Maybe RealSrcSpan -> R (Maybe RealSrcSpan)
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just RealSrcSpan
spn

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
_ -> R ()
token'rarrow
  HsLinearArrow XLinearArrow mult GhcPs
_ -> R ()
token'lolly
  HsExplicitMult XExplicitMult mult GhcPs
_ mult
mult -> do
    Text -> R ()
txt Text
"%"
    mult -> R ()
p_mult mult
mult
    R ()
space
    R ()
token'rarrow