{-# 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 Data.Maybe (isJust)
import qualified Data.Text as T
import GHC hiding (GhcPs, IE)
import Name (nameStableString)
import OccName (OccName (..))
import Ormolu.Printer.Combinators
import Ormolu.Utils
import RdrName (RdrName (..))

-- | 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. Data 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 ->
  -- | Indentation-bumping wrapper
  (R () -> R ()) ->
  -- | How to print the operator\/name
  R () ->
  -- | How to print the arguments
  [R ()] ->
  R ()
p_infixDefHelper :: Bool -> (R () -> R ()) -> R () -> [R ()] -> R ()
p_infixDefHelper isInfix :: Bool
isInfix inci' :: R () -> R ()
inci' 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 ()
forall a b. (a -> b) -> a -> b
$ 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
. R () -> R ()
inci' (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
        R () -> R ()
inci' (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
  Bool
goesAfterComment <- Maybe (Maybe HaddockStyle, RealSrcSpan) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Maybe HaddockStyle, RealSrcSpan) -> Bool)
-> R (Maybe (Maybe HaddockStyle, RealSrcSpan)) -> R Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> R (Maybe (Maybe HaddockStyle, RealSrcSpan))
getLastCommentSpan
  -- 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_ (Maybe HaddockStyle -> RealSrcSpan -> R ()
setLastCommentSpan (HaddockStyle -> Maybe HaddockStyle
forall a. a -> Maybe a
Just HaddockStyle
hstyle))
    RealSrcSpan spn :: RealSrcSpan
spn -> Maybe HaddockStyle -> RealSrcSpan -> R ()
setLastCommentSpan (HaddockStyle -> Maybe HaddockStyle
forall a. a -> Maybe a
Just 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)