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

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

import Control.Monad
import Data.Foldable (traverse_)
import Data.List (intersperse)
import qualified Data.Text as T
import GHC.Hs.Doc
import GHC.Hs.ImpExp
import GHC.Parser.Annotation
import GHC.Types.Name.Occurrence (OccName (..))
import GHC.Types.Name.Reader
import GHC.Types.SourceText
import GHC.Types.SrcLoc
import GHC.Unit.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 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 RdrName -> R ()
p_ieWrappedName :: IEWrappedName RdrName -> R ()
p_ieWrappedName = \case
  IEName LocatedN RdrName
x -> LocatedN RdrName -> R ()
p_rdrName LocatedN RdrName
x
  IEPattern EpaLocation
_ LocatedN RdrName
x -> do
    Text -> R ()
txt Text
"pattern"
    R ()
space
    LocatedN RdrName -> R ()
p_rdrName LocatedN RdrName
x
  IEType EpaLocation
_ LocatedN RdrName
x -> do
    Text -> R ()
txt Text
"type"
    R ()
space
    LocatedN RdrName -> R ()
p_rdrName LocatedN RdrName
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
  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
          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
  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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
sitcc
      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_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 HaddockStyle
hstyle Bool
needsNewline (L SrcSpan
l HsDocString
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

  Maybe RealSrcSpan
mSrcSpan <- SrcSpan -> R (Maybe RealSrcSpan)
getSrcSpan SrcSpan
l

  HaddockPrintStyle
printStyle <- forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f HaddockPrintStyle
poHaddockStyle
  let useSingleLineComments :: Bool
useSingleLineComments =
        forall (t :: * -> *). Foldable t => t Bool -> Bool
or
          [ HaddockPrintStyle
printStyle forall a. Eq a => a -> a -> Bool
== HaddockPrintStyle
HaddockSingleLine,
            forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
docLines forall a. Ord a => a -> a -> Bool
<= Int
1,
            -- Use multiple single-line comments when the whole comment is indented
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((forall a. Ord a => a -> a -> Bool
> Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> Int
srcSpanStartCol) Maybe RealSrcSpan
mSrcSpan
          ]

  let txt' :: Text -> R ()
txt' Text
x = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
x) (Text -> R ()
txt Text
x)
      body :: R () -> R ()
body R ()
s = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse R ()
s forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> R ()
txt' [Text]
docLines

  if Bool
useSingleLineComments
    then do
      Text -> R ()
txt forall a b. (a -> b) -> a -> b
$ Text
"-- " forall a. Semigroup a => a -> a -> a
<> Text
haddockDelim
      R () -> R ()
body forall a b. (a -> b) -> a -> b
$ R ()
newline forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt Text
"--"
    else do
      Text -> R ()
txt forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$
        [ Text
"{-",
          case (HaddockStyle
hstyle, HaddockPrintStyle
printStyle) of
            (HaddockStyle
Pipe, HaddockPrintStyle
HaddockMultiLineCompact) -> Text
""
            (HaddockStyle, HaddockPrintStyle)
_ -> Text
" ",
          Text
haddockDelim
        ]
      -- 'newline' doesn't allow multiple blank newlines, which changes the comment
      -- if the user writes a comment with multiple newlines. So we have to do this
      -- to force the printer to output a newline. The HaddockSingleLine branch
      -- doesn't have this problem because each newline has at least "--".
      --
      -- 'newline' also takes indentation into account, but since multiline comments
      -- are never used in an indented context (see useSingleLineComments), this is
      -- safe
      R () -> R ()
body forall a b. (a -> b) -> a -> b
$ Text -> R ()
txt Text
"\n"
      R ()
newline
      Text -> R ()
txt Text
"-}"

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needsNewline R ()
newline
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (SpanMark -> R ()
setSpanMark forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockStyle -> RealSrcSpan -> SpanMark
HaddockSpan HaddockStyle
hstyle) Maybe RealSrcSpan
mSrcSpan
  where
    docLines :: [Text]
docLines = HsDocString -> [Text]
splitDocString HsDocString
str
    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
"$" 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
_ -> (RealSrcSpan -> Bool) -> R (Maybe RealSrcSpan)
getEnclosingSpan (forall a b. a -> b -> a
const Bool
True)
      RealSrcSpan RealSrcSpan
spn Maybe BufSpan
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just RealSrcSpan
spn

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 -> R ()
space forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt (String -> Text
T.pack String
s)